diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-04 13:09:03 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-04 13:09:03 +0100 |
| commit | 04e68443040c7abad84d66477e98f93bed701760 (patch) | |
| tree | 2b6202afae659e773bf6916157d23e83edfa44e3 /lang | |
| download | eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.gz eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.bz2 eumel-src-04e68443040c7abad84d66477e98f93bed701760.zip | |
Initial import
Diffstat (limited to 'lang')
81 files changed, 29273 insertions, 0 deletions
diff --git a/lang/basic/1.8.7/doc/basic handbuch.1 b/lang/basic/1.8.7/doc/basic handbuch.1 new file mode 100644 index 0000000..2e604cb --- /dev/null +++ b/lang/basic/1.8.7/doc/basic handbuch.1 @@ -0,0 +1,1075 @@ +____________________________________________________________________________ + + +#on("b")##on ("u")# +#center#Betriebssystem E U M E L +#off ("u")# + + +#center#Basic + + + + +#off("b")# +#center#Lizenzfreie Software der +#on ("b")# + +#center#Gesellschaft für Mathematik und Datenverarbeitung mbH, +#center#5205 Sankt Augustin + + +#off("b")# +#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für +#center#nichtkommerzielle Zwecke gestattet. + +#center#Gewährleistung und Haftung werden ausgeschlossen + + +____________________________________________________________________________ +#page# +#page nr ("%", 1)# +#head# +EUMEL-BASIC-Compiler Inhalt % +#end# + +Inhalt + +1 Einleitung 3 + +2 Installation des BASIC-Compilers 4 + +3 Aufruf und Steuerung des BASIC-Compilers 5 + +4 Umgang mit dem BASIC-Compiler 7 +4.1 Erläuterungen zur Syntax 7 +4.2 Datentypen und Konstanten 10 +4.3 Variablen und Felder 12 +4.4 Operatoren 14 +4.5 Funktionen 19 +4.6 Typanpassung 22 +4.7 Aufruf von EUMEL-Prozeduren in BASIC-Programmen 23 + +5 Steuerung der Bildschirmausgaben 25 + +6 Grenzen des Compilers 26 + +7 Fehlerbehandlung 28 +7.1 Fehler zur Übersetzungszeit 28 +7.2 Fehler zur Laufzeit 30 + +8 Übersicht über die Anweisungen und Funktionen 31 + +9 Anpassung von Programmen an den EUMEL-BASIC-Compiler 96 +9.1 Unterschiede zwischen BASIC-Interpretern + und dem EUMEL-BASIC-Compiler 96 +9.2 Abweichungen von ISO 6373-1984 (Minimal-BASIC) 97 +9.3 Anpassung von Microsoft-BASIC Programmen + an den EUMEL-BASIC-Compiler 98 + +Anhang A: Reservierte Wörter 100 +Anhang B: Vom Scanner erkannte Symboltypen 103 +Anhang C: Übersicht über die Fehlermeldungen 106 +Anhang D: ELAN-Prozeduren des Compilers 113 +#page# + + +#page nr ("%", 3)# +#head# +EUMEL-BASIC-Compiler 1. Einleitung % + +#end# + +1. Einleitung + + +BASIC entspricht heute nicht mehr den Vorstellungen von einer modernen Program +miersprache. Dennoch wurde für das EUMEL-Betriebssystem ein Compiler für BASIC +entwickelt. Er soll vor allem dazu dienen, schon bestehende BASIC-Programme - +gegebenenfalls nach entsprechender Anpassung - auch unter EUMEL verfügbar zu +machen. +Der Compiler ist weitgehend an die ISO-Norm 6373 für Minimal-BASIC angelehnt. +Die Syntax und Bedeutung der Anweisungen orientiert sich in den meisten Fällen an +Microsoft-BASIC. Anweichungen treten insbesondere an den Stellen auf, an denen +Prinzipien des Betriebssystems EUMEL verletzt würden. +Verglichen mit dem ELAN-Compiler des EUMEL-Systems ist der BASIC-Compiler +beim Übersetzen recht langsam. Auch aus diesem Grund scheint es nicht sinnvoll, +den BASIC-Compiler zur Neuentwicklung größerer Programme einzusetzen. + +Sinn dieses Handbuchs ist es vor allem, Kenntnisse über den Umgang mit dem +EUMEL-BASIC-Compiler zu vermitteln. Das Handbuch ist auf keinen Fall als Ein +führung in die Programmiersprache BASIC gedacht, sondern es soll dem Benutzer mit +BASIC-Erfahrung die Arbeit mit dem EUMEL-BASIC-Compiler ermöglichen und +erleichtern. Neben Erfahrung in BASIC setzt dieses Buch an einigen Stellen auch +Grundkenntnisse über das EUMEL-System voraus. + + + +Zur #ib(4)#Notation#ie(4)# in dieser Beschreibung + +Bei der Beschreibung der Anweisungen und Funktionen und auch an anderen Stellen +werden in dieser Beschreibung Syntaxregeln für BASIC-Programme oder Teile davon +angegeben. Dabei werden folgende Zeichen mit besonderer Bedeutung verwendet: + +[ ] optionale Angabe +[...] beliebig häufige Wiederholung der letzten optionalen Angabe +| alternative Angabe, d.h. entweder die letzte links stehende Angabe oder + die nächste rechts stehende Angabe, aber nicht beide +< > in spitzen Klammern stehende Begriffe sind entweder definiert (z.B. <Va + riable>) oder werden hinter der Syntaxregel erläutert + +Die Notation der exportierten ELAN-Prozeduren des Compilers (besonders in An +hangD) entspricht der in den EUMEL-Handbüchern üblichen Prozedurkopf- +Schreibweise. +#page# +#head# +EUMEL-BASIC-Compiler 2. Installation des BASIC-Compilers % + +#end# + +2. #ib(3)#Installation des BASIC-Compilers#ie(3)# + + +Der EUMEL-BASIC-Compiler wird auf zwei Disketten mit jeweils 360 KByte +Speicherkapazität ausgeliefert. +Auf der Diskette "BASIC.1" befindet sich das #ib(3)#Generatorprogramm#ie(3)#("gen.BASIC") zur +Installation des EUMEL-BASIC-Systems. +Legen Sie diese Diskette in das Laufwerk ihres Rechners ein und geben Sie in der +Task, in der das BASIC-System installiert werden soll, folgende Zeile nach 'gib +kommando :' (oder 'maintenance :') ein: + +archive ("BASIC.1"); fetch ("gen.BASIC", archive); run + +Lassen Sie die Diskette 'BASIC.1' im Laufwerk und antworten Sie auf die Frage +"Archiv "BASIC.1" eingelegt(j/n)?" mit "j". Das Generatorprogramm holt nun einige +Dateien von der Diskette. Nach Zugriff auf das Archiv erscheint die Meldung "Archiv +abgemeldet!" und die Frage "Archiv 'BASIC.2' eingelegt(j/n)?". Legen Sie nun statt +des Archivs 'BASIC.1' das Archiv 'BASIC.2' in das Laufwerk ein und drücken Sie bitte +wiederum "j". Nach weiteren Archivoperationen erscheint dann wieder die Meldung +"Archiv abgemeldet". Sie können nun die Diskette "BASIC.2" aus dem Laufwerk +entnehmen. +Das Generatorprogramm insertiert nun alle Programme des BASIC-Systems in der +Task. Dieser Vorgang nimmt einige Zeit in Anspruch. Zum Abschluß erscheint die +Meldung "BASIC-System installiert". +Der EUMEL-BASIC-Compiler steht Ihnen nun in der Task (und in nachfolgend +eingerichteten Söhnen) zur Verfügung. +#page# +#head# +EUMEL-BASIC-Compiler 3. Aufruf und Steuerung des BASIC-Compilers % + +#end# + +3. #ib(4)#Aufruf und #ib(3)#Steuerung des BASIC-Compilers#ie(3)##ie(4)# + + + + +Übersetzen von BASIC-Programmen + +Ein BASIC-Programm, das vom Compiler übersetzt werden soll, muß sich dazu in +einer EUMEL-Textdatei befinden (Syntax vgl. Kap. 4.). Steht das BASIC-Programm +zum Beispiel in der Datei "Programm.17+4", so wird der Compiler mit + + #ib(3)#basic#ie(3)# ("Programm.17+4") + +zum Übersetzen dieses Programms aufgerufen. +In einem Vordurchlauf werden die Zeilennummern des Programms auf Richtigkeit +überprüft. Beim eigentlichen Compilerdurchlauf wird das BASIC-Programm dann mit +Hilfe des EUMEL-Coders in einen von der EUMEL-0-Maschine ausführbaren Code +übersetzt. + +Das Programm wird mit 'check on' (Zeilennummergenerierung) übersetzt. +Ein 'runagain' wie bei ELAN-Programmen ist bei BASIC-Programmen zur Zeit +leider nicht möglich. + + + +Insertieren von BASIC-Programmen + +Der BASIC-Compiler kann BASIC-Programme auch insertieren. Das ganze Pro +gramm bildet dabei eine Prozedur, die nach dem Insertieren wie eine 'normale' +ELAN-Prozedur aufgerufen werden kann. +Zum Insertieren wird der Compiler mit einem zusätzlichen Text-Parameter aufge +rufen: + + #ib(3)#basic#ie(3)# ("Programm.17+4", "blackjack") + +Das Programm wird übersetzt und, falls keine Fehler gefunden wurden, fest einge +tragen ('insertiert'). Gestartet wird das Programm aber nicht. +"blackjack" ist nun der Prozedurname, unter dem das BASIC-Programm nach erfolg +reichem Insertieren aufgerufen werden kann. +Bei 'packets' erscheint jetzt der Eintrag 'BASIC.blackjack' in der Liste der insertierten +Pakete, und ein 'help ("blackjack")' zeigt, daß eine Prozedur 'blackjack' nun tatsäch +lich in der Task bekannt ist. Die Prozedur 'bulletin' funktioniert für insertierte +BASIC-Programme nicht. Sie ist aber auch nicht nötig, da das 'Paket' mit dem +BASIC-Programm ohnehin nur eine Prozedur enthält und ihr Name ja schon aus +dem Namen des Paketes hervorgeht. + +#on ("b")# +Beachten Sie: + - Der Prozedurname muß der Syntax für ELAN-Prozedurnamen entsprechen, darf + aber #on ("b")#keine Leerzeichen enthalten. + - Die BASIC-Programme können über den Prozedurnamen nur aufgerufen wer + den; die Übergabe von Parametern ist ebenso wie Wertlieferung nicht möglich. + - Jedes Insertieren belegt Speicherplatz im Codebereich der Task. Weil der Coder + und der Compiler ebenfalls recht viel Code belegen, kann es (vor allem, wenn + die BASIC-Programme lang sind) schnell zu einem Code-Überlauf kommen + (Compiler Error 305). Es sollten daher nur die Programme insertiert werden, für + die dies wirklich nötig ist. + - Achten Sie bei der Wahl des Namens für die gelieferte Prozedur darauf, daß sie + nicht ungewollt Prozeduren des Betriebssystems überdecken. (Der Aufruf 'ba + sic("tadellos","help")' wäre z.B. gar nicht tadellos, denn 'help' wäre nach dem + Insertieren überdeckt). + - Auch beim Insertieren werden die BASIC-Programme mit 'check on' übersetzt. +#off ("b")# + + +Ausgabe der übersetzten Zeilen während des +Compilierens +Mit '#ib(3)#basic list#ie(3)# (TRUE)' wird der Compiler so eingestellt, daß beim Übersetzen die +aktuelle Programmzeile ausgegeben wird. Diese Ausgabe kann auch mit '#ib(3)#sysout#ie(3)#' +umgeleitet werden. Zum Beispiel: + + sysout ("Fehlerprotokoll"); basic ("Programm.17+4") + +Dies kann beim #ib(3)#Debugging#ie(3)# von BASIC-Programmen eine wertvolle Hilfe sein, da in +der Ausgabedatei die Fehler sofort hinter der betreffenden Programmzeile vermerkt +werden. Das 'sysout' muß in Monitortasks ('gib kommando:') direkt vor dem Aufruf +des Compilers gegeben werden, weil der Monitor 'sysout' sonst wieder zurücksetzt. + +Mit 'basic list (FALSE)' kann die Ausgabe der Programmzeilen beim Übersetzen +wieder ausgeschaltet werden. + +#page# +#head# +EUMEL-BASIC-Compiler 4. Umgang mit dem BASIC-Compiler % + +#end# + +4. Umgang mit dem BASIC-Compiler + + + +4.1. Erläuterungen zur #ib(3)#Syntax#ie(3)# + + +Ein zu übersetzendes Programm muß dem BASIC-Compiler in Form einer +#ib(3)#EUMEL-Textdatei#ie(3)# übergeben werden. (Es gelten somit auch die für EUMEL-Text +dateien üblichen Begrenzungen, z.B. höchstens 32000 Zeichen pro Zeile und höch +stens 4075 Dateizeilen pro Datei.) +BASIC-Programme setzen sich aus Programmzeilen zusammen; jede Dateizeile der +#ib(3)#Programmdatei#ie(3)# bildet eine BASIC-Programmzeile. Die Syntax für ein Programm sieht +damit so aus: + + +<Programmzeile>[<Programmzeile>][...]EOF + +Dabei bedeutet #ib(3)#EOF (end of file)#ie(3)# das Ende der Programmdatei. + +Eine #ib(3)#Programmzeile#ie(3)# hat folgende Syntax: + + +[<Zeilennummer>][<Anweisung>][:<Anweisung>][...][:]EOL + +Die #ib(3)#Zeilennummer#ie(3)# dient unter anderem als Sprungadresse an den Anfang der Pro +grammzeile während der Laufzeit des Programms (vgl. 'GOTO' und 'GOSUB'). Sie ist +fakultativ (d.h. sie muß nicht geschrieben werden). Durch sparsame Verwendung von +Zeilennummern (nämlich nur da, wo sie benötigt werden) kann eine gewisse Steige +rung der #ib(3)#Übersichtlichkeit von BASIC-Programmen#ie(3)# erreicht werden. Hat eine Pro +grammzeile keine Zeilennummer, so wird bei Fehlermeldungen (sowohl während der +Übersetzung als auch zur Laufzeit des Programms) die letzte Zeilennummer mit +angegeben, die davor auftrat. +Zeilennummern dürfen im Bereich von 1 bis 32767 liegen und müssen unbedingt in +aufsteigender Reihenfolge vergeben werden. Zeilennummern dürfen keine Leerzeichen +enthalten und müssen mit einem Leerzeichen abgeschlossen werden. Um spätere +Ergänzungen zu ermöglichen, ist eine Numerierung im Abstand zehn empfehlenswert. + +Hier ein Beispiel, wie ein BASIC-Programm in einer EUMEL-Datei aussehen +könnte: + + +...........................Einmaleins............................ +10 CLS: PRINT "Kleines Einmaleins" + FOR zahl% = 1 TO 10 + PRINT + 'Erzeugung einer Zeile + FOR faktor% = 1 TO 10 + PRINT TAB (faktor% * 5); + PRINT USING "\#\#\#"; faktor% * zahl%; + NEXT faktor% + NEXT zahl% + + + + +Die Syntax der Anweisungen, die vom EUMEL-BASIC-Compiler übersetzt werden +können, ist ausführlich im Kapitel 8 beschrieben. + +Der #ib(3)#Doppelpunkt#ie(3)# dient als Trennzeichen zwischen Anweisungen. Ihm muß nicht +unbedingt eine Anweisung folgen. Er kann somit als explizites "Ende der +Anweisung"-Symbol aufgefaßt werden (#ib(3)#EOS, "end of statement"#ie(3)#). + +#ib(3)#EOL (end of line)#ie(3)# ist das Ende einer Dateizeile. (Dieses "Zeichen" ist ebenso wie +EOF beim Editieren der Datei nicht sichtbar.) +Das #ib(3)#Hochkomma#ie(3)# ("'", Code 39) wird vom Compiler ebenfalls als EOL interpretiert. +Alle dem Hochkomma in der Dateizeile folgenden Zeichen werden überlesen. Dies +ermöglicht das Schreiben von Kommentaren ohne Verwendung der +'REM'-Anweisung. + +Es sei hier bereits bemerkt, daß sich durch die Realisierung des Übersetzers als +#on ("b")#Compiler gewisse Unterschiede gegenüber Interpretern #off ("b")#ergeben (siehe hierzu Kap. 9). +Der wesentliche Unterschied ist, daß der Interpreter dem Programmtext analog zum +Programmablauf folgt, der Compiler das Programm aber von vorne bis hinten Zeile für +Zeile übersetzt. Dies hat zur Folge, daß z.B. die Dimensionierungen von Feldvariablen +#on ("b")#textuell vor der Verwendung der Variablen stattfinden müssen#off ("b")# und nicht, wie bei +Interpretern, nur im Ablauf des Programms vorher ausgeführt werden müssen. + + + +Weitere Schreibregeln + +#on ("b")# +1. #ib(3)#Groß-/Kleinschreibung#ie(3)##off ("b")# +Für den BASIC-Compiler bestehen zwischen kleinen und großen Buchstaben keiner +lei Unterschiede, es sei denn es handelt sich um Textdenoter (Textkonstanten). +Daher können alle #ib(3)#Schlüsselwörter#ie(3)# und #ib(3)#Variablennamen#ie(3)# mit kleinen oder großen +Buchstaben geschrieben werden. Aus der Tatsache, daß zwischen großen und kleinen +Buchstaben nicht unterschieden wird, folgt aber bespielsweise auch, daß die Variab +lennamen (vgl. 4.3.) 'hallo' und 'HALLO' ein und dieselbe Variable bezeichnen. + +#on ("b")# +2. #ib(3)#Reservierte Wörter#ie(3)##off ("b")# +Der BASIC-Compiler erkennt eine ganze Reihe #on("i")#reservierter Wörter#off("i")#. Es handelt sich +hierbei im wesentlichen um die Namen der Anweisungen und Funktionen. Sie sollten +im eigenen Interesse darauf achten, daß sich sowohl vor als auch hinter reservier +ten Wörtern stets mindestens ein #on ("b")##ib(3)#Leerzeichen#ie(3)##off ("b")# (Blank) befindet. Der #ib(3)#Scanner#ie(3)# (ver +gleiche AnhangB) erkennt zwar manchmal die reservierten Wörter auch ohne Leer +zeichen, aber unter bestimmten Umständen kann es auch zu erkannten oder - noch +schlimmer - vom Compiler unerkannten Fehlern kommen. +Hierzu zwei Beispiele: +Die Anweisung 'IF a > b THENPRINT "größer"' führt beim Compilieren zur Fehler +meldung "Syntaxfehler: THEN oder GOTO erwartet". +Wesentlich gefährlicher ist da schon die Programmzeile + "LEThallo = 3 : PRINT hallo", +denn die unerwartete Wirkung ist die Ausgabe von "0" auf dem Bildschirm. Der Wert +"3" wurde nämlich nicht der Variablen mit dem Namen "hallo" zugewiesen, sondern +einer Variablen namens "LEThallo". + +#on ("b")# +3. Bedeutung der #ib(3)#Leerstelle#ie(3)# ("Blank") für den Compiler#off("b")# +Wie schon aus dem vorhergehenden Punkt ersichtlich kann das Fehlen von trennen +den Leerstellen unschöne Effekte haben, denn der #ib(3)#Scanner#ie(3)# (vgl. AnhangB) des +BASIC-Compilers erkennt anhand der Leerstelle (Code 32) beim Durchlauf durch das +Programm, daß ein #ib(3)#Symbol#ie(3)# zu Ende ist. +Es kommt somit immer dann zu Fehlern, wenn zwei Symbole (z.B. reservierte Wörter, +Konstanten, Variablen etc.) nicht durch Leerzeichen getrennt sind, und der Scanner +sie als ein Symbol "versteht". +Beispiel: + "a = 3 : b = 4 : PRINT a b" erzeugt die Ausgabe "34". + "a = 3 : b = 4 : PRINT ab" erzeugt hingegen die Ausgabe "0", denn der +Compiler sieht "ab" als #on ("b")#einen Variablennamen an. #off ("b")# + + + +4.2. #ib(3)#Datentypen#ie(3)# und #ib(3)#Konstanten#ie(3)# + + +Der EUMEL-BASIC-Compiler unterscheidet grundsätzlich zwischen zwei Daten +typen, nämlich zwischen #ib(3)#Texte#ie(3)#n und #ib(3)#Zahlen#ie(3)#. + +#on ("b")# +#ib(3)#Datentyp TEXT#ie(3)# #off ("b")# +Texte dürfen alle Zeichen enthalten (Codes 0 bis 255) und bis zu 32000 Zeichen lang +sein. +Die zugehörigen Konstanten werden von #ib(3)#Anführungszeichen#ie(3)# begrenzt, z.B.: + "Anzahl Einträge: " + "2.32 DM" + "General-Musik-Direktor" +Anführungszeichen (Code 34) dürfen #on("i")#innerhalb#off("i")# von Text-Konstanten nicht vor +kommen. + +Bei Zahlen unterscheidet der Compiler noch zwischen #ib(3)#INTs#ie(3)# (#ib(3)#Ganzzahlen#ie(3)#) und REALs +(#ib(3)#Gleitkommazahlen#ie(3)#). Diese entsprechen im Hinblick auf den Wertebereich genau den +in ELAN bekannten INTs und REALs. + +#on ("b")# +#ib(3)#Datentyp INT#ie(3)# #off ("b")# +INT-Werte dürfen zwischen -32768 und 32767 liegen. INT-Konstanten dürfen aber +#on("i")#nur#off("i")# aus Ziffern und einem optionalen '%'-Zeichen am Ende bestehen. Das bedeutet, +daß die INT-Konstanten im Bereich von 0 bis 32767 liegen können. +Ein nachgestelltes '%'-Zeichen kennzeichnet eine Konstante nochmals explizit als +INT. (Diese Option wurde aus Kompatibilitätsgründen implementiert.) + +#on ("b")# +#ib(3)#Datentyp REAL#ie(3)# #off ("b")# +REALs können Werte zwischen -9.999999999999*10#u#126#e# und +9.999999999999*10#u#126#e# annehmen. +Die kleinste positive von Null verschiedene Zahl ist 9.999999999999*10#u#-126#e#. +Der kleinste REAL-Wert mit x + 1.0 > 1.0 ist gleich 10#u#-12#e#. +REAL-Konstanten werden gebildet aus Vorkommastellen, Dezimalpunkt, Nachkom +mastellen, Zeichen "E" oder "D" (jeweils auch klein) für den #ib(3)#Exponent#ie(3)#en gefolgt vom +Vorzeichen und den Ziffern des Exponenten. +Dabei müssen nicht für jede REAL-Konstante alle diese Elemente benutzt werden. +Unverzichtbar sind #on("i")#entweder#off("i")# der Dezimalpunkt #on("i")#oder#off("i")# der Exponent. Ebenso müssen +zumindest entweder Vor- oder Nachkommastellen vorhanden sein. + +Beispiele für gültige REAL-Konstanten sind: + 0. + .01 + 1E-17 + 2.9979D8 + .3e-102 + 100.e+7 + +Nicht erlaubt sind dagegen folgende Schreibweisen für REAL-Konstanten: + e12 (#ib(3)#Mantisse#ie(3)# fehlt) + 100 (ist INT-Konstante) + . (weder Vor- noch Nachkommastellen) + .E-12 (dito) + 1exp-3 ('exp' nicht erlaubt) + -1.99e30 (Mantisse hat Vorzeichen) + +Das letzte Beispiel zeigt, daß auch vor REAL-Konstanten keine #ib(3)#Vorzeichen#ie(3)# erlaubt +sind. Da normalerweise keine REAL-Konstanten, sondern vielmehr numerische +Ausdrücke verlangt werden, können durch Voranstellen des Operators '-' (vgl. 4.4.) +auch #ib(3)#negative Zahlenwerte#ie(3)# leicht erzeugt werden. + +An REAL-Konstanten darf eines der Zeichen "!" und "\#" angehängt werden. Diese +Option wurde aus Kompatibilitätsgründen eingebaut. Wird ein "!" oder "\#" an eine +INT-Konstante angehängt, so verwandelt es diese in eine REAL-Konstante. +Beispiel: 10000! oder 10000\# entspricht 10000. oder 1E4 + + +#page# + +4.3. Variablen und Felder + + +Variablen + +Der BASIC-Compiler stellt für die in 4.2. vorgestellten Datentypen TEXT, INT und +REAL auch Variablen zur Verfügung. +Die #ib(3)#Variablennamen#ie(3)# müssen folgenden Bedingungen genügen: +- Ein Variablenname muß mit einem Buchstaben beginnen. +- Variablennamen dürfen ab der zweiten Stelle außer Buchstaben auch Ziffern, Dezi + malpunkte sowie die Zeichen "!", "\#", "$" und "%" enthalten. Leerzeichen dürfen + in Variablennamen dagegen nicht vorkommen. +- Variablennamen dürfen nicht mit FN beginnen (vgl. 4.5. benutzer-definierte Funk + tionen). +- #ib(3)#Reservierte Wörter#ie(3)# (siehe Anhang A) dürfen kein Variablenname sein. Als Teiltexte + dürfen reservierte Wörter aber in Variablennamen enthalten sein (auch am Anfang). + +Variablennamen dürfen beliebig lang sein, und alle Zeichen eines Variablennamens +sind signifikant. + +Welchen Typ eine Variable hat, entscheidet der Compiler nach folgenden #ib(3)#Kriterien#ie(3, " für den Typ einer Variablen")# (in +der Reihenfolge ihrer Beachtung): +- Ist das letzte Zeichen des Namens ein "!" oder "\#", so bezeichnet er eine + REAL-Variable. +- Ist das letzte Zeichen ein "%", so handelt es sich um eine INT-Variable. +- Ist das letzte Zeichen des Namens ein "$", so ist die Variable vom Typ TEXT. +- Liegt das erste Zeichen des Namens im Bereich der mit einer #ib(3)#DEFINT#ie(3)#-Anweisung + (vgl. Kap. 8) festgelegten Buchstaben, so ist die Variable eine INT-Variable. +- Liegt das erste Zeichen im Bereich der mit einer #ib(3)#DEFSTR#ie(3)#-Anweisung (vgl. Kap. 8) + festgelegten Buchstaben, so handelt es sich um eine TEXT-Variable. +- Wenn keine der obigen Bedingungen erfüllt ist, dann bezeichnet der Name eine + Variable des Datentyps REAL. + +Variablen, denen noch kein Wert zugewiesen wurde, haben den Inhalt null (bei INT +und REAL) beziehungsweise Leertext (bei TEXT). + + + +Felder (#ib(4)#Arrays#ie(4)#) + +Ein Feld (Array) ist eine Ansammlung von mehreren Variablen gleichen Typs. Jedes +Feld hat einen Namen. Für die #ib(3)#Feldnamen#ie(3)# gelten die gleichen Regeln wie für die +Namen von normalen Variablen. Auch die Datentypen werden nach den gleichen +Kriterien bestimmt wie bei einfachen Variablen. +In einem Feld können die Elemente in bis zu 100 #ib(3)#Dimensionen#ie(3)# abgelegt werden. Auf +ein Element eines Feldes wird über den Feldnamen und den Index / die #ib(3)#Indizes#ie(3)# des +Elements zugegriffen. Beim Zugriff auf das Element müssen so viele Indizes ange +geben werden, wie das Feld Dimensionen hat. +Beispiel: +Das Feld 'tabelle' habe zwei Dimensionen. Mit 'tabelle (3, 5)' wird auf das Element +mit dem Index 3 in der ersten Dimension und dem Index 5 in der zweiten Dimension +zugegriffen. + +Beim ersten Zugriff auf ein Element eines Feldes wird anhand der Zahl der Indizes +die Anzahl der Dimensionen festgestellt und das Feld so eingerichtet, daß in jeder +Dimension der größte Index zehn ist. +Soll ein Feld mit anderen größten Indizes eingerichtet werden, so muß hierzu die +#ib(3)#DIM#ie(3)#-Anweisung verwendet werden (siehe Kapitel 8). + +Der kleinste Index ist voreingestellt auf null, kann aber mit der #ib(3)#OPTION BASE#ie(3)#- +Anweisung (vgl. Kap. 8) auch auf eins eingestellt werden. + +Die Elemente eines Feldes sind, wie auch die einfachen Variablen, mit den Werten +null (INT und REAL) beziehungsweise Leertext (TEXT) vorbesetzt, sofern ihnen noch +nichts zugewiesen wurde. + +#page# + +4.4. Operatoren + +Nachfolgend sind alle Operatoren aufgelistet, die vom EUMEL-BASIC-Compiler +übersetzt werden. + + +Arithmetische #ib(4)#Operatoren#ie(4, ", arithmetische")# + +#ib(3)##ie(3, "+")##ib(3)##ie(3, "-")##ib(3)##ie(3, "*")##ib(3)##ie(3, "/")# +#ib(3)##ie(3, "\")##ib(3)##ie(3, "MOD")##ib(3)##ie(3, "^")# + + Operand(en) Zweck Ergebnistyp + + + INT positives Vorzeichen INT + REAL positives Vorzeichen REAL + + INT, INT INT-Addition INT + REAL, REAL REAL-Addition REAL + + - INT negatives Vorzeichen INT + REAL negatives Vorzeichen REAL + + INT, INT INT-Subtraktion INT + REAL, REAL REAL-Subtraktion REAL + + * INT, INT INT-Multiplikation INT + REAL, REAL REAL-Multiplikation REAL + + / (INT, INT) #linefeed (0.5)# + REAL-Division REAL + REAL, REAL #linefeed (1.0)# + + \ INT, INT #linefeed (0.5)# + INT-Division INT + (REAL, REAL) #linefeed (1.0)# + +MOD INT, INT INT-Divisionsrest INT + REAL, REAL Divisionsrest nach REAL + Runden auf Ganzzahl (nicht INT) + + ^ (INT, INT) #linefeed (0.5)# + Potenzierung REAL + REAL, REAL #linefeed (1.0)# + + +#on ("b")# +Hinweis: #off ("b")# +Wird ein Operator mit numerischen Operanden unterschiedlichen Typs (also INT und +REAL) aufgerufen, so wird der INT-Operand nach REAL konvertiert und der Operator +mit den beiden REAL-Operanden aufgerufen. +Sind die Operandtypen in Klammern angegeben, so werden vor Ausführung der Ope +ration die Operanden zu den nicht eingeklammerten Typen konvertiert. +Da jede #ib(3)#Konvertierung#ie(3)# Zeit benötigt, sollte der Benutzer darauf achten, daß möglichst +wenig konvertiert werden muß. +Hierzu ein (etwas extremes, aber nicht seltenes) Beispiel: +Der Aufruf a%\b bewirkt zunächst eine Konvertierung von a% nach REAL: +CDBL(a%)\b. Intern wird die Berechnung dann aber wieder mit INTs ausgeführt: +CINT(CDBL(a%))\CINT(b). Das Ergebnis wird also erst nach drei Konvertierungen +geliefert. Schreibt man dagegen sofort a%\CINT(b), dann reicht eine Konvertierung +aus. + +Es muß außerdem bei den Operatoren +, - und * für INTs darauf geachtet werden, +daß das Ergebnis innerhalb des INT-Wertebereichs liegen muß, da es sonst zu +einem #ib(3)#INT-Überlauf#ie(3)# kommt. + + + +Text-Operator #ib(4)#+#ie(4)# + +#ib(3)##ie(3, "Operatoren, Text-")# +Für Text-Manipulationen wird der Operator '+' mit zwei TEXT-Operanden zur +Verfügung gestellt. Mit '+' werden zwei Texte aneinandergehängt (konkateniert). + + + +Vergleichsoperatoren#ib(4)##ie(4, "Operatoren, Vergleichs-")# + +Im EUMEL-BASIC gibt es folgende Vergleichsoperatoren: + +#ib(3)#=#ie(3)# gleich +#ib(3)#<>#ie(3)# ungleich +#ib(3)#<#ie(3)# kleiner +#ib(3)#>#ie(3)# größer +#ib(3)#<=#ie(3)# kleiner oder gleich +#ib(3)#>=#ie(3)# größer oder gleich + +Bei den numerischen Datentypen werden mit den Vergleichsoperatoren die Zahlen +werte verglichen. +Sollen ein INT und ein REAL verglichen werden, dann wird der INT vorher nach +REAL konvertiert und ein REAL-Vergleich vorgenommen. + +Bei Texten dienen die Vergleichsoperatoren zum Vergleich der Zeichencodes. Dies +ermöglicht zum Beispiel ein alphabetisches Sortieren von Wörtern, mit der Einschrän +kung, daß Groß- und Kleinbuchstaben unterschiedliche Zeichencodes haben (ver +gleiche EUMEL-Zeichensatz-Tabelle im Benutzerhandbuch) und somit verschieden +eingeordnet werden. +Es gilt a$ < b$, wenn die Zeichenkette in a$ codemäßig vor der Zeichenkette in b$ + steht: "a" < "b" (TRUE) "aa"< "a" (FALSE) + + +Die Vergleichsoperatoren liefern, je nachdem ob die Aussage wahr oder falsch ist, die +INT-Werte 0 (falsch) oder -1 (wahr). +Anhand des Ergebnisses einer Vergleichsoperation kann zum Beispiel der Programm +ablauf gesteuert werden (siehe Kapitel 8, IF-Anweisung). + + + +Logische Operatoren + +#ib(3)##ie(3, "Operatoren, logische")# +Die logischen Operatoren haben zwei Aufgaben: +1. logische (Boolsche) Verknüpfung von #ib(3)#Wahrheitswerte#ie(3)#n, die zum Beispiel von + Vergleichsoperationen geliefert werden und +2. bitweise Ausführung von logischen Verknüpfungen auf den internen (Zweierkom + plement-) Darstellungen von INT-Werten. + +Da für beide Aufgaben die gleichen Operatoren benutzt werden, wurden für die Wahr +heitswerte die INT-Werte 0 für falsch (Bitmuster: 0000000000000000) und -1 für +wahr (Bitmuster: 1111111111111111) gewählt. + + Operand(en) Zweck insbesondere gilt + +#ib(3)#NOT#ie(3)# INT #linefeed (0.5)# NOT0->-1 + #ib(3)#Negation#ie(3)# + (REAL) #linefeed (1.0)# NOT-1->0 + +#ib(3)#AND#ie(3)# INT, INT #ib(3)#UND-Verknüpfung#ie(3)# 0AND0->0 + 0AND-1->0 + -1AND0->0 + -1AND-1->-1 + + #ib(3)#OR#ie(3)# INT, INT #ib(3)#ODER-Verknüpfung#ie(3)# 0OR0->0 + 0OR-1->-1 + -1OR0->-1 + -1OR-1->-1 + +#ib(3)#XOR#ie(3)# INT, INT #ib(3)#Exklusiv-ODER-Verknüpfung#ie(3)# 0XOR0->0 + 0XOR-1->-1 + -1XOR0->-1 + -1XOR-1->0 + +#ib(3)#EQV#ie(3)# INT, INT #ib(3)#Äquivalenz-Verknüpfung#ie(3)# 0EQV0->-1 + 0EQV-1->0 + -1EQV0->0 + -1EQV-1->-1 + +#ib(3)#IMP#ie(3)# INT, INT #ib(3)#Implikations-Verknüpfung#ie(3)# 0IMP0->-1 + 0IMP-1->-1 + -1IMP0->0 + -1IMP-1->-1 + + + +Prioritäten der Operanden + + +Hier die Übersicht über alle Operatoren in der Reihenfolge ihrer Ausführung + + + Operator Priorität + + ^ Potenzierung 13 + +, - positives/negatives Vorzeichen 12 + *, / Multiplikation, REAL-Division 11 + \ INT-Division 10 + MOD Divisionsrest- (MOD-) Operation 9 + +, - Addition, Subtraktion 8 + =, <>, <, >, <=, >= Vergleichsoperatoren 7 + NOT Negation 6 + AND UND-Verknüpfung 5 + OR ODER-Verknüpfung 4 + XOR Exklusiv-ODER-Verknüpfung 3 + EQV Äquivalenz-Verknüpfung 2 + IMP Implikations-Verknüpfung 1 + + +Die Reihenfolge der Auswertung von Ausdrücken kann durch Klammern geändert +werden. + +Beachten Sie, daß der Operator '=' in BASIC die Funktion eines Vergleichsoperators +und des #ib(3)#Zuweisungsoperators#ie(3)##ib(3)##ie(3, "Operator, Zuweisungs-")# (siehe Kapitel 8, LET-Anweisung) hat. + +#page# + +4.5. #ib(3)#Funktionen#ie(3)# + + + +Standard-Funktionen + +Der EUMEL-BASIC-Compiler unterstützt eine ganze Reihe von Funktionen. Diese +Funktionen liefern Werte und können in Ausdrücken zusammen mit Konstanten, +Variablen und Operatoren verwendet werden. +Viele der eingebauten Funktionen arbeiten mit Argumenten, das heißt es werden den +Funktionen Werte übergeben. +In Kapitel 8 dieses Handbuches sind alle Funktionen ausführlich beschrieben. +Beispiele für #ib(3)#Funktionsaufrufe#ie(3)#: + SQR (17) Dieser Ausdruck liefert die Wurzel von 17 als REAL. + RIGHT$ (text$, 5) Dieser Ausdruck liefert die letzten fünf Textzeichen +#right#aus 'text$' als TEXT. + + + +Benutzer-definierte Funktionen + +Neben der Verwendung der standardmäßig verfügbaren Funktionen besteht für den +Benutzer die Möglichkeit, selbst Funktionen innerhalb eines Programms zu definieren. + +#on ("b")# +#ib(3)#Definition benutzer-definierter Funktionen#ie(3)# #off ("b")# +Hierzu dient die #ib(3)#DEF FN#ie(3)#-Anweisung (vergleiche Kapitel 8). +Die Syntax der DEF FN-Anweisung lautet: + +DEFFN<Name>[(<Parameter>[,<Parameter>][...])]= +#right#<Funktionsdefinition> + +<Name>: Zeichenfolge, die der Syntax für Variablennamen ent + sprechen muß. + FN<Name> bilden zusammen den Namen der neuen + Funktion. +<#ib(3)#Parameter#ie(3)#>: Zeichenfolge, die der Syntax für Variablennamen ent + sprechen muß. +<Funktionsdefinition>: Ausdruck, der Konstanten, Variablen, die Parameter der + Funktion und Aufrufe anderer Funktionen enthalten + darf. + +- Die benutzer-definierten Funktionen ("user functions") liefern, genau wie die + Standard-Funktionen, Werte. +- Das letzte Zeichen des Funktionsnamens gibt den Typ des Wertes an, den die + Funktion liefert. Soll die Funktion einen TEXT liefern, so muß der Name mit "$" + enden. Soll ein INT geliefert werden, muß der Name mit "%" enden. Für alle + anderen Endungen wird eine REAL-liefernde Funktion eingetragen. +- Die Syntax der Parameternamen entspricht der Syntax für die Namen von einfachen + Variablen. +- Die Parameter haben nur bei der Definition Gültigkeit. Hierbei 'überdecken' sie (für + diese Zeile) eventuell im BASIC-Programm vorhandene gleichnamige Variablen. +- Jeder Parameter darf in der Parameterliste nur einmal vorkommen. +- Bezeichnet der Funktionsname eine TEXT-liefernde Funktion, so muß auch die + Funktionsdefinition ein Ergebnis vom Typ TEXT liefern. Zwischen INTs und REALs + findet eine Typanpassung statt. +- Eine Funktion darf nicht in ihrer eigenen Definition erscheinen. +- Eine Funktion ist allein durch ihren Namen gekennzeichnet. Generische Funktionen + (gleicher Name, aber unterschiedliche Parameter) können somit nicht definiert wer + den. + +Beispiele für gültige Funktionsdefinitionen: + DEF FNPI = 3.1415927 + DEF FNumfang (radius) = 2.0 * FNPI * radius (Enthält Aufruf von FNPI) + DEF FNhallo$ (dummy$) = "Hallo " + name$ (name$ kommt im + #right#BASIC-Programm vor) + DEF FNheavyside% (x) = ABS (SGN (x) = 1) + +Beispiele für ungültige Funktionsdefinitionen: + DEF FNfunct (a, b, a) = a ^ 2 + b (a kommt zweimal als Parameter vor) + DEF FNfr (x) = x * FNfr (x - 1) (rekursive Definition) + + +#on ("b")# +#ib(3)#Aufruf benutzer-definierter Funktionen#ie(3)# #off ("b")# + +FN<Name> [ ( <Argument> [, <Argument>] [...] ) ] + +<#ib(3)#Argument#ie(3)#> : Ausdruck, der für den entsprechenden Parameter bei der Evaluation + (Auswertung) der Funktion eingesetzt werden soll + +- Beim Funktionsaufruf werden die Argumente in der Reihenfolge ihres Auftretens für + die Parameter eingesetzt. Für TEXT-Parameter müssen die Argumente ebenfalls + TEXTe liefern. Zwischen INTs und REALs findet eine Typanpassung statt. +- Die Anzahl der Argumente muß genau mit der Anzahl der Parameter übereinstim + men. +- Für in der Funktionsdefinition vorkommende Variablen wird der zum Zeitpunkt des + Funktionsaufruf gültige Wert eingesetzt. +- Die Definition der Funktion muß dem ersten Aufruf der Funktion textuell voraus + gehen. +- Eine Definition gilt für alle textuell folgenden Aufrufe, bis die Funktion wieder neu + definiert wird. + +Beispiele für korrekte Funktionsaufrufe (bezogen auf obige Beispiel-Definitionen): + PRINT FNPI / 2.0 (Ausgabe: 1.570796) + PRINT FNumfang (20) (Ausgabe: 125.6637) + LET name$ = "Purzelbär":PRINT FNhallo$ ("") (Ausgabe: Hallo Purzelbär) + PRINT heavyside% (-17.3) (Ausgabe: 0) + +Beispiele für falsche Funktionsaufrufe (bezogen auf obige Beispiel-Definitionen): + PRINT FNPI (10) (kein Argument erwartet) + PRINT FNumfang (Argument erwartet) + PRINT FNhallo$ (zahl%) (Falscher Typ des Arguments) + PRINT FNheavyside (17.4, -12.3) (Zu viele Argumente) + + +#page# + +4.6. #ib(3)#Typanpassung#ie(3)# + + +In BASIC wird, im Gegensatz zu ELAN, nicht sehr streng zwischen den numerischen +Datentypen unterschieden, sondern es finden häufig automatische Typanpassungen +statt. Zu solchen Typanpassungen kommt es vor allem bei der Zuweisung, bei Opera +toren und bei Funktionen, aber auch bei einigen Anweisungen. +Die automatische Typanpassung hat zwei Nachteile: +1. Die Typkonvertierung von INT nach REAL und umgekehrt kostet Zeit während der + Programmausführung. +2. Es kann zu sehr unangenehmen Laufzeitfehlern kommen, wenn eine REAL- + INT-#ib(3)#Konvertierung#ie(3)# mit Fehler abbricht, weil der REAL-Wert außerhalb des + INT-Wertebereichs liegt. + +Allgemein gilt also, daß sich der Programmierer auch in BASIC über die Typen der +verwendeten Objekte im klaren sein sollte. Außerdem ist zu beachten, daß bei Konver +tierungen von REAL nach INT immer gerundet wird. + +Genaueres zur Typanpassung bei der Zuweisung finden Sie in Kapitel 8 bei der +LET-Anweisung. +Über Typkonvertierung bei Operatoren informiert Kapitel 4.4. +Informationen über die Funktionen betreffenden Typkonvertierungen befinden sich am +Anfang von Kapitel 8 und direkt bei der Beschreibung der jeweiligen Funktionen +(ebenfalls in Kapitel 8). + +#page# + +4.7. Aufruf von EUMEL-Prozeduren in + BASIC-Programmen + + + +Der EUMEL-BASIC-Compiler bietet die Möglichkeit, insertierte ELAN-Prozeduren +(und auch insertierte BASIC-Programme) in BASIC-Programmen aufzurufen. Hierzu +werden die beiden Anweisungen #ib(3)#CALL#ie(3)# und #ib(3)#CHAIN#ie(3)# (identisch) sowie die Funktion +#ib(3)#USR#ie(3)# zur Verfügung gestellt. +Mit der CALL-Anweisung (siehe auch Kapitel 8) können Prozeduren aufgerufen +werden, die keinen Wert liefern und nur die BASIC-Datentypen INT, REAL und/oder +TEXT als Parameter benötigen. +Beispiele: + CALL list + CALL taskstatus ("PUBLIC") + CALL cursor (10, 21) + CALL getcursor (x%, y%) + +Das letzte Beispiel zeigt, daß auch #ib(3)#VAR-Parameter#ie(3)# im ELAN-Sinne übergeben +werden können. + +Die Funktion USR dient im Gegensatz zu CALL zum Aufruf von #ib(3)#wertliefernden Pro +zeduren#ie(3)#. Die Prozeduren dürfen allerdings nur einen der BASIC-Datentypen INT, +REAL oder TEXT liefern. Es gilt auch bei USR, wie bei CALL, daß die aufgerufenen +Prozeduren nur Parameter der Typen INT, REAL oder TEXT haben dürfen. +Beispiele: + PRINT USR e (Ausgabe: 2.718282) + PRINT USR compress (" EUMEL ") (Ausgabe: EUMEL) + +#on ("b")# +Wichtige Hinweise zu CALL, CHAIN und USR: #off ("b")# +1. Bei den Parametern finden keinerlei Typkonvertierungen statt (ELAN- + Prozeduren werden ja gerade anhand der Typen ihrer Parameter eindeutig identifi + ziert). +2. Die Prozedurnamen nach CALL, CHAIN und USR dürfen keine Leerzeichen ent + halten, weil die Prozedur sonst nicht identifiziert werden kann. + Beispiel: CALLlernsequenzauftastelegen(...) statt + CALLlernsequenzauftastelegen(...) +3. Die Prozedurnamen können (nach BASIC-Konvention) auch Großbuchstaben + enthalten. + Beispiel: CALLcursor(17,4) ist äquivalent zu + CALLCURSOR(17,4) + + +Wie in Kapitel 3 erläutert kann ein BASIC-Programm auch insertiert werden. Somit +können mit der CALL-Anweisung auch andere (vorher insertierte) BASIC- +Programme aufgerufen werden. +Beispiel: +CALL blackjack ('blackjack' sei der Prozedurname, unter dem ein BASIC- + Programm zuvor insertiert wurde.) + +Die sonst in einigen BASIC-Dialekten vorhandene Möglichkeit, Programme oder +#ib(3)#Programmsegmente#ie(3)# nachzuladen, kann so durch Aufrufe von insertierten Programmen +nachgebildet werden. +#page# +#head# +EUMEL-BASIC-Compiler 5. Steuerung der Bildschirmausgaben % + +#end# + +5. #ib(4)#Steuerung der #ib(3)#Bildschirmausgaben#ie(3)##ie(4)# + + + +Die Ausgaben von BASIC-Programmen ('PRINT' und 'WRITE') werden im Paket +'basic output' behandelt. Dieses Paket ermöglicht unter anderem, daß die Ausgabe +auf das Terminal mit der Prozedur + + PROC #ib(3)#basic page#ie(3)# (BOOL CONST status) + +gesteuert werden können. Wird dabei 'TRUE' eingestellt, so wartet die Ausgabe bei +Erreichen der letzten Terminalzeile auf die Eingabe eines Zeichens, bevor sie fortfährt. +Das Eingabezeichen wird nach Ausgabe von ">>" in der rechten unteren Ecke des +Bildschirms erwartet und wie folgt interpretiert: + +#linefeed (1.5)# + Löschen des Bildschirms und Ausgabe der nächsten Bildschirmseite + Ausgabe der nächsten Zeile + Abbruch des Programms mit der Fehlermeldung "'halt' vom Terminal" + 'basic page' wird auf 'FALSE' gesetzt #linefeed (1.0)#und mit der normalen Ausgabe + weitergemacht + +Alle anderen Tasten bewirken eine Ausgabe der nächste Bildschirmseite (#ib(3)#Scrolling#ie(3)#). + +Ist 'basic page' auf 'FALSE' gesetzt, so kann durch Eingabe von vor einem Zei +lenwechsel 'basic page' auf 'TRUE' gesetzt werden. +#page# +#head# +EUMEL-BASIC-Compiler 6. Grenzen des Compilers % + +#end# + +6. #ib(3)#Grenzen des Compilers#ie(3)# + + +Es gibt verschiedene Grenzen, die bei der Benutzung des BASIC-Compilers erreicht +werden können. + +#on ("b")# +Grenzen des #ib(3)#EUMEL-Coder#ie(3)#s #off ("b")# +Da ein BASIC-Programm vom Compiler als eine Prozedur im Coder eingetragen +wird, darf der Code für ein BASIC-Programm die #ib(3)#Modulgrenze#ie(3)# von 7500 Byte Code +nicht überschreiten. +Sollte dies doch einmal der Fall sein (#ib(3)#Compiler Error 308#ie(3)#), so gibt es folgende +Abhilfe-Möglichkeiten: +- Zerlegen des BASIC-Programms in mehrere BASIC-Programme, wobei ein + Programm das andere während der Ausführung aufrufen kann (vgl.4.7.). + Bei dieser Methode können die Teilprogramme aber nicht mit gemeinsamen Variab + len arbeiten. +- Auslagerung von Programmteilen (z.B. Unterprogrammen) in ELAN-Prozeduren, + die insertiert und vom BASIC-Programm aufgerufen werden können (vgl.4.7.). + Dieses Verfahren bietet die Möglichkeit, Variablen zwischen BASIC-Programm und + ELAN-Prozedur über die Prozedurschnittstelle auszutauschen. + +Neben der Begrenzung des Codes ist auch die Größe des Datenspeicherbereichs pro +BASIC-Programm begrenzt. Insgesamt dürfen die Datenobjekte eines BASIC- +Programms nicht mehr als 32 KByte Speicherplatz belegen. Andernfalls kommt es +zum #ib(3)#Compiler Error 307#ie(3)#. + +Eine weitere Grenze des EUMEL-Coders stellt die maximal zulässige Anzahl der +#ib(3)#Labels#ie(3)# (interne Sprungadressen) dar. Es können nur höchstens 2000 Labels vom +Coder verwaltet werden. Der BASIC-Compiler vergibt für jede gefundene Zeile mit +Zeilennummer ein Label und benötigt auch bei Schleifen (FOR-NEXT, WHILE- +WEND), Fallunterscheidungen (IF-Anweisung), Unterprogramm-Aufrufen (GOSUB) +und bei der Definition von benutzer-definierten Funktionen (DEF) Labels. +Beim Auftreten des #ib(3)#Compiler Errors 304#ie(3)# (zu viele Label) ist Abhilfe relativ leicht +dadurch möglich, daß Zeilennummern nur den Zeilen vergeben werden, die tatsächlich +angesprungen werden (d.h. zu denen es GOTOs oder GOSUBs gibt). + +#on ("b")# +Grenzen des BASIC-Compilers #off ("b")# +Die interne #ib(3)#Namenstabelle#ie(3)# des BASIC-Compilers kann etwa 4240 Einträge aufneh +men. Ein Eintrag in dieser Tabelle wird für jede Variable, für jedes Feld, für jede +benutzer-definierte Funktion und für jeden Parameter einer benutzer-definierten +Funktion sowie für jede Konstante erzeugt. Numerische Konstanten erhalten, sofern +sie konvertiert werden müssen, sogar zwei Einträge in der Namenstabelle. +Bei Auftreten des seltenen Fehlers "volle Namenstabelle" kann durch eine Aufteilung +des BASIC-Programms in Teilprogramme oder eine Auslagerung von Unterprogram +men in ELAN-Prozeduren Abhilfe geschaffen werden. + +#on ("b")# +Sonstige EUMEL-Grenzen #off ("b")# +Außer den bisher genannten Begrenzungen sei nochmals auf die Begrenzung des +#ib(3)#Codebereichs pro Task#ie(3)# hingewiesen (maximal 256 KByte Code). +Da der EUMEL-Coder und der BASIC-Compiler recht viel Code belegen, sollte +"vorsichtig" insertiert werden, also nur das, was wirklich benötigt wird. +Auch die übrigen Grenzen des EUMEL-Systems sind zu beachten (vergleiche hierzu +die Aufstellung der möglichen Compiler Errors im EUMEL-Benutzerhandbuch)! + +#page# +#head# +EUMEL-BASIC-Compiler 7. Fehlerbehandlung % + +#end# + +7. #ib(3)#Fehlerbehandlung#ie(3)# + + +7.1. #ib(3)#Fehler zur Übersetzungszeit#ie(3)# + +Endeckt der BASIC-Compiler bei der Übersetzung eines BASIC-Programms Fehler, +so werden diese auf dem Bildschirm angezeigt und ins #ib(3)#Notebook#ie(3)# eingetragen. +Nur (syntaktisch) fehlerfreie Programme werden zur Ausführung gebracht beziehungs +weise insertiert. +Im #ib(3)#Vordurchlauf#ie(3)# werden die Zeilennummern auf Richtigkeit überprüft. Falls bereits +hiebei Fehler festgestellt werden, bricht der Compiler die Übersetzung nach dem +Vordurchlauf ab. +Im #ib(3)#Hauptdurchlauf#ie(3)# wird das Programm Zeile für Zeile auf syntaktische Richtigkeit +überprüft und gleichzeitig übersetzt. Wird dabei in einer Programmzeile ein Fehler +entdeckt, so wird er angezeigt und die Übersetzung des Programms #on("i")#in der nächsten +Programmzeile#off("i")# fortgesetzt. Eine Ausnahme von dieser Regel bildet nur die #ib(3)#DEF FN#ie(3)#- +Anweisung, bei der bei gewissen Fehlern die Übersetzung fortgesetzt wird. (Der +Grund hierfür liegt darin, daß die Folgefehlerzahl besonders bei der DEF FN- +Anweisung sehr groß wäre, wenn beim Auftreten eines Fehlers die Übersetzung der +Zeile sofort abgebrochen würde. Die Parameter würden dann nämlich nicht oder +falsch abgelegt, und bei jedem Aufruf der Funktion würde ein Fehler gemeldet.) + +Eine Übersicht über alle verwendeten Fehlermeldungen zur Übersetzungszeit befindet +sich im AnhangC. + + + +Interne Compilerfehler + +Neben den "normalen" Fehlern (siehe oben) kann es in seltenen Fällen möglicher +weise auch zu internen Fehlern kommen. +Es gibt zwei verschiedene Sorten von internen Fehlern: +1. interne Fehler, die das Compilerprogramm selbst feststellt. + Solche Fehler bewirken die Meldung "Interner Fehler !" (meist mit näherer Erläu + terung) und die Fortsetzung der Übersetzung in der nächsten Programmzeile. +2. Fehler, die in anderen Paketen des BASIC-Systems oder des EUMELs (z.B. im + EUMEL-Coder) während der Übersetzungszeit ausgelöst werden (siehe auch + Kapitel 6: "Grenzen des Compilers"). + Solche Fehler werden mit "#ib(3)#BASIC-Compiler ERROR#ie(3)#" und eventuell näheren + Angaben gemeldet. Beim Auftreten eines solchen Fehlers wird die Übersetzung + des gesamten Programms abgebrochen. + +Sollten bei Ihrer Arbeit mit dem EUMEL-BASIC-Compiler interne Fehler auftreten, +die nicht auf das Überschreiten von Compilergrenzen zurückzuführen sind, dann +wären wir Ihnen für eine Meldung der Fehler dankbar. Bitte senden Sie eine Fehler +beschreibung an: + + Gesellschaft für Mathematik und Datenverarbeitung + Schloß Birlinghoven + Postfach 1240 + 5205 Sankt Augustin 1 + +Die Fehlerbeschreibung sollte nach Möglichkeit folgende Informationen enthalten: +- verwendete Hardware +- Urlader-Version +- EUMEL-Version +- Programmtext des Programms, das den Fehler auftreten ließ +- genaue Angabe der ausgegebenen Fehlermeldung + + +#page# + +7.2. #ib(3)#Fehler zur Laufzeit#ie(3)# + +Treten während der Laufzeit eines BASIC-Programms Fehler auf, so wird die Ausfüh +rung des Programms mit einer entsprechenden Fehlermeldung abgebrochen. +Da die meisten Laufzeit-Fehlermeldungen durch Prozeduren des EUMEL-Systems +(und nicht des BASIC-Systems) erzeugt werden, entsprechen sie oft nicht der +BASIC-Terminologie. (Beispielsweise führt ein zu großer Feldindex zu der Fehlermel +dung "Ueberlauf bei Subskription".) + +Die bei Laufzeitfehlern gemeldete #ib(3)#Fehlerzeile#ie(3)# bezieht sich nicht (wie bei ELAN-Pro +grammen) auf die Nummer der Dateizeile, sondern auf die letzte der Programmzeile +vorangegangene BASIC-Zeilennummer. + +Fast alle ausgelösten Laufzeitfehler erzeugen auch #ib(3)#Fehlercodes#ie(3)#. Dabei liefern Fehler +aus EUMEL-Betriebssystem-Prozeduren die EUMEL-Standard-Fehlercodes (vgl. +Systemhandbuch), zum Beispiel wird beim Fehler "INT-Ueberlauf" der Fehlercode 4 +geliefert. +Laufzeitfehler, die in Prozeduren des BASIC-Systems ausgelöst werden, liefern dage +gen den in Microsoft-BASIC üblichen Fehlercode plus 1000. So liefert die Meldung +"Keine Daten mehr für READ" den Fehlercode 1004 (MS-BASIC: "Out of data", +Fehlercode 4). +Es läßt sich so anhand des gelieferten Fehlercodes ermitteln, ob der Fehler im +BASIC-System oder an einer anderen Stelle des EUMEL-Systems ausgelöst wurde. + +Eine Übersicht über die innerhalb des BASIC-Systems erzeugten Fehlermeldungen +enthält Anhang C. + diff --git a/lang/basic/1.8.7/doc/basic handbuch.2 b/lang/basic/1.8.7/doc/basic handbuch.2 new file mode 100644 index 0000000..1379e9e --- /dev/null +++ b/lang/basic/1.8.7/doc/basic handbuch.2 @@ -0,0 +1,2441 @@ +#page nr ("%", 31)# +#head# +EUMEL-BASIC-Compiler 8. Übersicht über die Befehle und Funktionen % + +#end# + +8. Übersicht über die Anweisungen und Funktionen + + + +In diesem Kapitel sind alle Anweisungen und Funktionen des vom Compiler übersetz +baren BASIC-Sprachumfangs in alphabetischer Reihenfolge aufgeführt. +Auch die Anweisungsbestandteile (z.B. ELSE und TO) sind mit einem Hinweis auf die +zugehörige Anweisung eingeordnet. +Sind bei Funktionen INT- oder REAL-Ausdrücke als Argumente angegeben, so ist +dies als Hinweis auf den Sinn der Funktion zu verstehen. Es können auch Ausdrücke +des jeweils anderen Datentyps eingesetzt werden. Wird statt eines INT-Ausdrucks +ein REAL-Ausdruck angegeben, so darf dessen Wert aber nur innerhalb des +Wertebereichs für INTs liegen, da der REAL-Wert bei der Ausführung der Funktion +in einen INT-Wert konvertiert wird. + + + +Funktion : ABS + +Zweck : Berechnung des Betrages (Absolutwertes) einer Zahl + +Syntax : ABS (<num. Ausdruck>) + +Erklärung : Liefert den Betrag des numerischen Ausdrucks. + Das Ergebnis ist vom gleichen Typ wie das Argument. + + +Beispiel : 10 a = -12.74 + 20 PRINT ABS (a) + Ausgabe: 12.74 + +Vergleiche : SGN-Funktion + + + +Operator : AND + +Siehe Kapitel 4.4. (Operatoren) + + + +Anweisungsbestandteil : AS + +Siehe NAME-Anweisung + + + +Funktion : ASC + +Zweck : Ermittlung des ASCII-Codes eines Textzeichens + +Syntax : ASC (<TEXT-Ausdruck>) + +Erklärung : Die Funktion liefert den ASCII-Code des ersten Zeichens des + TEXT-Ausdrucks. + Der Code wird als INT geliefert. + + +Beispiel : 10 a$ = "Guten Tag !" + 20 PRINT ASC (a$) + Ausgabe: 71 + +Vergleiche : CHR$-Funktion (Komplementärfunktion) + + + +Funktion : ATN + +Zweck : Berechnung des Arcustangens + +Syntax : ATN (<num. Ausdruck>) + +Erklärung : Die Funktion liefert den Arcustangens des + numerischen Ausdrucks in Radiant. + + +Beispiel : 10 LET x = 4 + 20 PRINT ATN (x) + Ausgabe: 1.325818 + +Vergleiche : TAN-Funktion (Komplementärfunktion), SIN, COS + + + +Anweisungsbestandteil : BASE + +Siehe OPTION BASE-Anweisung + + + +Anweisung : CALL + +Zweck : Aufruf einer insertierten Prozedur + +Syntax : CALL <Prozedurname> #right#[ (<Parameter> [, <Parameter>] [...] ) ] + +Erklärung : <Prozedurname>: Folge aus Zeichen, die für Prozeduren im + EUMEL-System zugelassen sind (also Buchstaben und - ab der + zweiten Stelle - Zahlen), aber keine Leerzeichen. + + <Parameter>: <CONST-Parameter> | <VAR-Parameter> + + <CONST-Parameter>: Ausdruck (genau des von der Prozedur + benötigten Typs) + <VAR-Parameter>: Variable (genau des von der Prozedur benö + tigten Typs) + + Die Prozedur mit dem angegebenen <Prozedurnamen> wird mit den + angegebenen Parametern aufgerufen. + Die aufgerufene Prozedur darf keinen Wert liefern (vgl. USR-Funk + tion). + + Mögliche Fehlerfälle: + - Eine Prozedur mit dem Namen <Prozedurnamen> und den an + gegebenen Parametern gibt es nicht. + - Die Prozedur liefert einen Wert. + - Die Prozedur benötigt Parametertypen, die in BASIC nicht bekannt + sind (z.B. BOOL, FILE, TASK, QUIET). + - Ein Parameter ist CONST, es wird aber ein VAR-Parameter ver + langt. + + Weitere Informationen finden Sie in Kapitel 4.7. + +Hinweis : 1. Bei den Parametern wird keine Typkonvertierung vorgenommen. + 2. Der Prozedurname muß (entgegen der ELAN-Gewohnheit) ohne + Leerzeichen angegeben werden. + 3. Statt des Anweisungswortes CALL kann auch CHAIN geschrieben + werden. CALL und CHAIN werden im EUMEL-BASIC nicht wie + in Microsoft-BASIC benutzt. + + +Beispiel : 10 CALL sysout ("Meine Datei") + 20 PRINT "Dieser Text geht nun in die Datei" + 30 CALL sysout ("") + 40 PRINT "Wieder auf den Bildschirm" + + +Vergleiche : USR-Funktion + + + +Funktion : CDBL + +Zweck : Konvertierung in den Datentyp REAL + +Syntax : CDBL (<num. Ausdruck>) + +Erklärung : Das Ergebnis des numerischen Ausdrucks wird als REAL geliefert. + + +Beispiel : 10 LET a! = 17 + 20 PRINT USR max (CDBL (a!), 152.3) + 30 REM max benötigt zwei REALs als Parameter + + +Vergleiche : CINT-Funktion + + + +Anweisung : CHAIN + +Vollkommen identisch mit der CALL-Anweisung (Erklärung siehe dort !) + + + +Funktion : CHR$ + +Zweck : Erzeugung eines Textzeichens mit einem bestimmten ASCII-Code + +Syntax : CHR$ (<INT-Ausdruck>) + +Erklärung : Die Funktion liefert das Zeichen mit dem ASCII-Code, den der + INT-Ausdruck angibt. + Das Zeichen wird als TEXT geliefert. + Die Leistung der Funktion ist nur für Werte im Bereich 0 bis 255 + definiert. + + +Beispiel : 10 PRINT CHR$ (61) + Ausgabe: = + +Vergleiche : ASC-Funktion (Komplementärfunktion) + + + +Funktion : CINT + +Zweck : Konvertierung in den Datentyp INT + +Syntax : CINT (<num. Ausdruck>) + +Erklärung : Das Ergebnis des numerischen Ausdrucks wird als INT geliefert. + REALs werden gerundet. Werte außerhalb des INT-Bereichs führen + zu einem INT-Überlauf. + + +Beispiel : 10 LET a = 17.625 + 20 PRINT CINT (a); CINT (-a) + Ausgabe: 18 -18 + +Vergleiche : CDBL-, FIX-, INT-Funktionen + + + +Anweisung : CLS + +Zweck : Löschen des Bildschirms + +Syntax : CLS + +Erklärung : Löscht den Bildschirm und positioniert den Cursor in die linke obere + Bildschirmecke (Position 1, 1). + + +Beispiel : 10 CLS + 20 PRINT "PROGRAMMBEGINN" + + + + +Funktion : COS + +Zweck : Berechnung des Cosinus eines Radiantwertes + +Syntax : COS (<Winkel>) + +Erklärung : <Winkel>: REAL-Ausdruck, der den Winkel in Radiant angibt. + Die Funktion liefert den Cosinus des Winkels als REAL. + + +Beispiel : 10 PI = 3.141593 + 20 PRINT COS (PI/4) + Ausgabe: .7071067 + +Vergleiche : SIN-, TAN-Funktionen + + + +Funktion : CSRLIN + +Zweck : Ermittlung der aktuellen Cursorzeile + +Syntax : CSRLIN + +Erklärung : Geliefert wird die Nummer der Zeile (als INT), in der sich der Cursor + auf dem Bildschirm befindet. Die oberste Zeile hat die Nummer 1. + + +Beispiel : 10 CLS + 20 PRINT + 30 PRINT CSRLIN + Ausgabe: 2 + +Vergleiche : POS-Funktion + + + +Funktion : CVD, CVI + +Zweck : Decodierung von in Texten verschlüsselten Zahlenwerten + +Syntax : CVD (<TEXT-Ausdruck>) + CVI (<TEXT-Ausdruck>) + +Erklärung : INTs und REALs können (mit MKI$ und MKD$) zu Texten codiert + werden. + CVD decodiert einen in 8 TEXT-Zeichen codierten REAL-Wert. + CVI decodiert einen in 2 TEXT-Zeichen codierten INT-Wert. + Es wird beim ersten Zeichen des TEXT-Ausdrucks mit der Dekodie + rung begonnen. + Ist der TEXT zu kurz, so wird mit der Meldung "Ueberlauf bei Subs + kription" abgebrochen. + + +Beispiel : 10 zahl$ = MKD$ (3.1415) + 20 PRINT CVD (zahl$) + Ausgabe: 3.1415 + +Vergleiche : MKD$-, MKI$- Funktionen (Komplementärfunktionen) + + + +Anweisung : DATA + +Zweck : Ablegen von Konstanten + +Syntax : DATA [<string>] [, [<string>]] [...] + +Erklärung : <string> : <quoted string> | <unquoted string> + <quoted string> : von Anführungszeichen umschlossene Zeichen + folge, die alle Zeichen außer Anführungs + zeichen enthalten darf + <unquoted string>: Zeichenfolge, die alle Zeichen außer Komma + und Doppelpunkt enthalten darf + + Eine DATA-Anweisung stellt einen Datenspeicher dar, der mit READ + (s.d.) ausgelesen werden kann. + In der DATA-Anweisung können "quoted strings" oder "unquo + ted strings" angegeben werden. "quoted strings" können später nur + noch als Texte ausgelesen werden. + Bei "unquoted strings" wird der Datentyp in der DATA-Anweisung + dagegen nicht festgelegt. Sie können also als INTs, REALs oder + TEXTe ausgelesen werden. Sollen "unquoted strings" Zahlenwerte + darstellen, so müssen sie den in BASIC üblichen Schreibregeln für + die numerischen Konstanten des jeweiligen Typs genügen. Es sind + allerdings zusätzlich noch Vorzeichen erlaubt. + Wenn die <strings> nicht angegeben sind, so wird ein "nil-Datum" + abgelegt. Dieses bewirkt bei einem READ mit numerischer Variable + die Lieferung des Wertes null und bei einem READ mit TEXT-Vari + able die Lieferung eines Leertextes. + + Die DATA-Anweisungen können an beliebiger Stelle im Programm + (vor oder hinter den zugehörigen READ-Anweisungen) stehen. + + Alle DATA-Anweisungen eines Programms bilden zusammen einen + großen sequentiellen Speicher, auf den mit READ der Reihe nach + zugegriffen wird. Intern wird ein sogenannter READ-DATA-Zeiger + geführt, der immer auf das nächste auszulesende Element zeigt. + Die RESTORE-Anweisung (s.d.) ermöglicht es, den READ- + DATA-Zeiger auf das erste Element einer bestimmten DATA-Zeile + zu setzen. + + +Beispiel : 2020 PRINT "Stadt", "Land", "Fluß" + 2030 READ stadt$, land$, fluß$ + 2040 PRINT stadt$, land$, fluß$ + . + 5000 DATA Paris, Frankreich, Seine + + +Vergleiche : READ-, RESTORE-Anweisungen + + + +Funktion : DATE$ + +Zweck : Abrufen des aktuellen Tagesdatums + +Syntax : DATE$ + +Erklärung : Das Tagesdatum wird als Text in der Form TT.MM.JJ geliefert. + + +Beispiel : 10 PRINT "Heute ist der " + DATE$ + Ausgabe (z.B.): Heute ist der 28.08.87 + +Vergleiche : TIME$-Funktion + + + +Anweisung : DEFDBL, DEFINT, DEFSNG, DEFSTR + +Zweck : Definition von Anfangsbuchstaben zur Kennzeichnung bestimmter + Variablentypen + +Syntax : DEFDBL <Buchstabe1> [ - <Buchstabe2>] + #right#[, <Buchstabe3> [ - <Buchstabe4>] ] [...] + DEFINT <Buchstabe1> [ - <Buchstabe2>] + #right#[, <Buchstabe3> [ - <Buchstabe4>] ] [...] + DEFSNG <Buchstabe1> [ - <Buchstabe2>] + #right#[, <Buchstabe3> [ - <Buchstabe4>] ] [...] + DEFSTR <Buchstabe1> [ - <Buchstabe2>] + #right#[, <Buchstabe3> [ - <Buchstabe4>] ] [...] + + +Erklärung : Mit den aufgeführten Anweisungen ist es möglich, bestimmte Buch + staben festzulegen, die, wenn sie als Anfangsbuchstaben eines + Variablennamens verwendet werden, der Variablen einen bestimmten + Typ zuordnen. + + Die Typfestlegung durch Kennzeichnung mit den Zeichen '!', '\#', '%' + oder '$' hat jedoch Vorrang vor den festgelegten Anfangsbuchstaben. + Eine genaue Erläuterung, nach welchen Kriterien der BASIC-Compi + ler den Typ einer Variablen feststellt, befindet sich in Kapitel 4.3. + + Die DEFINT-Anweisung legt Anfangsbuchstaben für INT-Variablen + fest. + Mit der DEFSTR-Anweisung werden Anfangsbuchstaben von + TEXT-Variablen festgelegt. + Die Anweisungen DEFDBL- und DEFSNG- wurden nur aus Kom + patibilitätsgründen implementiert. Sie werden zwar auf syntaktische + Richtigkeit überprüft, aber ansonsten vom Compiler nicht beachtet. + + Werden bei den Anweisungen ganze Buchstabenbereiche angegeben, + so muß der Buchstabe vor dem Bindestrich auch im Alphabet vor + dem Buchstaben hinter dem Bindestrich stehen. + +Hinweis : 1. Die oben beschriebenen Anweisungen gelten stets erst für die im + weiteren Text neu benutzten (also neu eingerichteten) Variablen. + 2. Die beschriebenen Anweisungen dürfen auch mehr als einmal in + einem Programm vorkommen. Die Buchstaben, die in der zweiten + und in den folgenden Anweisungen festgelegt werden, werden + #on("izusätzlich#off("i zu den in der ersten Anweisung festgelegten Buchsta + ben als Kennzeichen für den betreffenden Datentyp vom Compiler + vermerkt. + 3. Der Compiler überprüft nicht, ob gleiche Buchstaben als Kennzei + chen für mehr als einen Variablentyp angegeben werden (siehe + Kapitel 4.3.). Der Benutzer ist also selbst dafür verantwortlich, daß + solche Überschneidungen nicht vorkommen. + + +Beispiel : 10 DEFSTR s - z + 20 DEFINT a - h, n + 30 DIM tabelle (17) 'TEXT-Feld + 40 LET c = 4 'INT-Variable + 50 LET nummer = 17 'INT-Variable + 60 LET ueberschrift = "Willkommen" 'TEXT-Variable + 70 LET reellezahl = 19.563 'REAL-Variable + 80 LET aha\# = -1.36E17 'REAL-Variable + + + + +Anweisung : DEF FN + +Zweck : Definition einer benutzer-definierten Funktion + +Syntax : DEF FN<Name> [ ( <Parameter> [, <Parameter>] #right# [...] ) ] = <Funktionsdefinition> + +Erklärung : <Name> : Zeichenfolge, die der Syntax für Variablennamen + entsprechen muß + FN<Name> bilden zusammen den Namen der + neuen Funktion + <Parameter>: Zeichenfolge, die der Syntax für Variablennamen + entsprechen muß + <Funktionsdefinition>: Ausdruck, der Konstanten, Variablen, die + Parameter der Funktion und Aufrufe + anderer Funktionen enthalten darf + + Mit der DEF FN-Anweisung wird eine benutzer-definierte Funktion + ("user function") mit dem Funktionsnamen FN<Name> definiert + (vergleiche hierzu auch Kapitel 4.5.). + Die benutzer-definierte Funktion liefert, genau wie die standard + mäßig eingebauten Funktionen, einen Wert, der sich aus der Auswer + tung des unter <Funktionsdefinition> angegebenen Ausdrucks + ergibt. + Das letzte Zeichen des Funktionsnamens gibt den Typ des Wertes + an, den die Funktion liefert. Soll die Funktion einen TEXT liefern, so + muß der Name mit "$" enden. Soll ein INT geliefert werden, muß der + Name mit "%" enden. Für alle anderen Endungen wird eine REAL- + liefernde Funktion eingetragen. + Bezeichnet der Funktionsname eine TEXT-liefernde Funktion, so + muß auch die Funktionsdefinition ein Ergebnis vom Typ TEXT liefern. + Zwischen INTs und REALs findet eine Typanpassung statt. + + Die Parameter stehen für die beim Aufruf der Funktion übergebenen + Argumente. + Sie haben nur bei der Definition Gültigkeit. Hierbei 'überdecken' sie + (für diese Zeile) eventuell im BASIC-Programm vorhandene gleich + namige Variablen. + Die Syntax der Parameternamen entspricht der Syntax der Namen + von einfachen Variablen. + Jeder Parameter darf in der Parameterliste nur einmal vorkommen. + + In der Definition dürfen auch Aufrufe von zuvor definierten anderen + "user functions" erscheinen, nicht aber die zu definierende Funktion + selbst (rekursive Definition). + + Die Funktionen sind allein durch ihre Namen gekennzeichnet. Gene + rische Funktionen (gleicher Name, aber unterschiedliche Parameter) + können somit nicht definiert werden. + +Hinweis : 1. Die Definition einer "user function" muß ihrem ersten Aufruf + immer textuell vorausgehen. + 2. "user functions" können auch mehrfach definiert werden. Der + Compiler gibt in einem solchen Fall aber eine Warnung aus, da + die neue Definition nur für die textuell folgenden Aufrufe gültig ist. + + +Beispiel : 10 LET pi = 3.1415927 + 20 DEF FNkreisflaeche (radius) + #right#= 4.0 * pi * radius * radius + 1010 PRINT FNkreisflaeche (1.75) + Ausgabe: 38.48451 + + + +Anweisung : DIM + +Zweck : Dimensionierung eines Feldes + +Syntax : DIM <Felddeklaration> [, <Felddeklaration>] [...] + +Erklärung : <Felddeklaration>: <Feldvariable> (<INT-Konstante> + #right#[, <INT-Konstante>] [...] ) + <Feldvariable>: Name des Feldes (Syntax wie Name von einfachen + Variablen, vgl. 4.3.) + + Mit der DIM-Anweisung wird ein Feld dimensioniert, das heißt die + Anzahl seiner Dimensionen sowie der kleinste und größte Index in + jeder Dimension werden festgelegt und der Speicherplatz für seine + Elemente (siehe 4.3.) wird reserviert. + + Der kleinste Index in allen Dimensionen richtet sich nach der letzten + vorausgegangenen OPTION BASE-Anweisung. + Geht der Dimensionierung die Anweisung OPTION BASE 0 textuell + voraus oder ist keine OPTION BASE-Anweisung vor der Dimensio + nierung vorhanden, so ist der kleinste Index in allen Dimensionen + null. + Wenn der Dimensionierung aber eine OPTION BASE 1-Anweisung + vorausgeht, dann ist der kleinste Index in allen Dimensionen eins. + + Der größte Feldindex wird für jede Dimension durch die in Klammern + stehenden INT-Konstanten angegeben. Die Anzahl dieser INT-Kon + stanten bestimmt auch, wie viele Dimensionen das dimensionierte + Feld hat. + + Wird auf ein Element einer Feldvariablen zugegriffen, ohne daß die + Feldvariable vorher dimensioniert wurde, dann wird das Feld automa + tisch dimensioniert, wobei die Anzahl der Dimensionen anhand der + Anzahl der Indizes beim Aufruf ermittelt wird. Der größte Feldindex + wird bei dieser automatischen Dimensionierung in jeder Dimension + auf zehn gesetzt. Der kleinste Index richtet sich nach den vorausge + gangenen OPTION BASE-Anweisungen (siehe oben). + + Fehlerfälle bei der Dimensionierung: + - "Das Feld ist bereits dimensioniert": + Das Feld wurde bereits explizit, oder automatisch durch den Zugriff + auf ein Feldelement dimensioniert . + - "Die Obergrenze muß >= 1 sein": + Es wurde versucht, 0 als größten Index in einer Dimension festzu + legen, obwohl mit OPTION BASE der kleinste Index auf eins fest + gelegt wurde. + + Fehlerfälle beim Zugriff auf ein Feldelement: + - "Dimensioniert in ... Dimensionen, gefundene Anzahl Indizes ...": + Beim Zugriff wurde eine Anzahl von Indizes gefunden, die nicht mit + der Anzahl der Dimensionen übereinstimmt (Fehler zur Über + setzungszeit). + - "Ueberlauf bei Subskription" oder "Unterlauf bei Subskription": + Der Index ist zu groß beziehungsweise zu klein (Fehler zur Lauf + zeit). + + +Beispiel : 10 DIM a% (20, 10), text$ (30, 40) + 20 DIM tabelle (5, 7, 25) + 30 LET element = matrix (1, 7) + + Zeile 30 führt eine automatische Dimensionierung durch, die einem + DIM matrix (10, 10) entspricht. + + + +Anweisungsbestandteil : ELSE + +Siehe IF-Anweisung + + + +Anweisung : END + +Zweck : Beenden der Programmausführung eines BASIC-Programms + +Syntax : END + +Erklärung : END beendet die Programmausführung des BASIC-Programms ohne + eine Meldung (im Gegensatz zu STOP, s.d.). + END-Anweisungen dürfen im Programm an beliebiger Stelle stehen, + und es darf auch mehr als eine END-Anweisung in einem + Programm vorkommen. + Der Compiler übersetzt ein Programm auch nach Erreichen einer + END-Anweisung weiter. + Nach der letzten Anweisung eines Programms muß kein END stehen. + + +Beispiel : 2020 PRINT "Das war's !" + 2030 REM Hiernach hört's auf + 2040 END + + +Vergleiche : STOP-Anweisung + + + +Anweisungsbestandteil : EOF + +Siehe INPUT-Anweisung + + + + +Operator : EQV + +Siehe Kapitel 4.4. (Operatoren) + + + +Funktion : ERL + +Zweck : Ermittlung der letzten Fehlerzeile + +Syntax : ERL + +Erklärung : Die Nummer der Zeile, in der der letzte Fehler auftrat, wird als INT + geliefert. + +Hinweis : ERL ist realisiert durch Aufruf der Prozedur 'errorline' des Betriebs + systems. + Da die Fehlerbehandlungs-Anweisung ON ERROR nicht zur Verfü + gung steht, ist diese Funktion nicht im üblichen BASIC-Sinne + brauchbar. + +Vergleiche : ERM$, ERR-Funktionen, ERROR-Anweisung + + + +Funktion : ERM$ + +Zweck : Ermittlung der letzten Fehlermeldung + +Syntax : ERM$ + +Erklärung : Die letzte Fehlermeldung wird als TEXT geliefert. + +Hinweis : ERM$ ist realisiert durch Aufruf der Prozedur 'errormessage' des + Betriebssystems. + Da die Fehlerbehandlungs-Anweisung ON ERROR nicht zur Verfü + gung steht, ist diese Funktion nicht im üblichen BASIC-Sinne + brauchbar. + +Vergleiche : ERL-, ERR-Funktionen, ERROR-Anweisung + + + +Funktion : ERR + +Zweck : Ermittlung des letzten Fehlercodes + +Syntax : ERR + +Erklärung : Der Code des letzten aufgetretenen Fehlers wird als INT geliefert. + +Hinweis : ERR ist realisiert durch Aufruf der Prozedur 'errorcode' des Betriebs + systems. + Da die Fehlerbehandlungs-Anweisung ON ERROR nicht zur Verfü + gung steht, ist diese Funktion nicht im üblichen BASIC-Sinne + brauchbar. + +Vergleiche : ERL-, ERM$-Funktionen, ERROR-Anweisung + + + +Anweisung : ERROR + +Zweck : Auslösen eines Fehlers mit bestimmtem Fehlercode + +Syntax : ERROR <INT-Ausdruck> + +Erklärung : Es wird ein Fehler mit dem durch den INT-Ausdruck bestimmten + Fehlercode ausgelöst. + +Hinweis : ERROR ist realisiert durch Aufruf der Prozedur 'errorstop' des Be + triebssystems. + Da die Fehlerbehandlungs-Anweisung ON ERROR nicht zur Verfü + gung steht, ist diese Anweisung nicht im üblichen BASIC-Sinne + brauchbar. + +Vergleiche : ERL-, ERM$-, ERR-Funktionen + + + +Funktion : EXP + +Zweck : Berechnung einer Potenz der Eulerschen Zahl + +Syntax : EXP (<REAL-Ausdruck>) + +Erklärung : Die Funktion liefert e (die Basis des natürlichen Logarithmus) poten + ziert mit dem Wert des REAL-Ausdrucks. + Bei zu großen Werten kommt es zum Fehler 'REAL-Ueberlauf'. + Das Ergebnis der Funktion wird als REAL geliefert. + + +Beispiel : 10 PRINT EXP (10.0) + Ausgabe: 22026.47 + +Vergleiche : LOG-Funktion (Komplementärfunktion) + + + +Funktion : FIX + +Zweck : Ermittlung der Vorkommastellen einer REAL-Zahl + +Syntax : FIX (<REAL-Ausdruck>) + +Erklärung : Die Funktion schneidet die Nachkommastellen ab und liefert nur die + Vorkommastellen des REAL-Ausdrucks. + Die Vorkommastellen werden ebenfalls als REALs geliefert. + + +Beispiel : 10 zahl = 1.2345E2 + 20 PRINT FIX (zahl) + Ausgabe: 123 + +Vergleiche : CINT-, INT-Funktionen + + + +Anweisung : FOR + +Zweck : Beginn einer Zählschleife + +Syntax : FOR <num. Variable> = <Anfangswert> #ib(3)#TO#ie(3)# <Endwert> + #right#[ #ib(3)#STEP#ie(3)# <Schrittweite> ] + <Schleifenrumpf> + + +Erklärung : <num. Variable> : INT- oder REAL-Variable + <Anfangswert> : numerischer Ausdruck + <Endwert> : numerischer Ausdruck + <Schrittweite> : numerischer Ausdruck + <Schleifenrumpf>: Folge von Programmzeilen + + Die FOR-Anweisung erlaubt die komfortable Programmierung von + automatischen Zählschleifen (sogenannten FOR-NEXT-Schleifen). + Gelangt das Programm während der Ausführung an eine FOR-An + weisung, so werden zunächst die Ausdrücke <Anfangswert>, + <Endwert> sowie gegebenenfalls <Schrittweite> ausgewertet. Der + Anfangswert wird dann der Variablen zugewiesen. + Wenn der Wert der Variablen größer ist als der Endwert (bzw. kleiner + als der Endwert bei negativer Schrittweite), dann wird das Programm + mit der nach dem korrespondierenden NEXT (s.d.) folgenden + Anweisung fortgesetzt. + Ist dies jedoch nicht der Fall, werden die Anweisungen des <Schlei + fenrumpfs> ausgeführt. Erreicht das Programm nun die zum FOR + gehörige NEXT-Anweisung (gleiche Variable), so wird der Wert der + Variablen um die Schrittweite erhöht beziehungsweise erniedrigt (je + nach Vorzeichen), und wieder an den Anfang der Schleife verzweigt. + Hier findet dann wieder der Vergleich des Variableninhalts mit dem + Endwert statt (siehe oben). + + Die Laufvariable darf innerhalb der Schleife in Ausdrücken vorkom + men. Sie darf sogar verändert werden (, was aber zu unübersichtli + chen Effekten führen kann). Auch eine Schachtelung mehrerer + Schleifen mit der gleichen Laufvariable ist syntaktisch möglich, sollte + aber #on("iunter allen Umständen#off("i vermieden werden. + + FOR-NEXT-Schleifen dürfen (auch mit WHILE-WEND-Schleifen, + s.d.) geschachtelt werden. Überschneidungen von FOR-NEXT- + Schleifen und WHILE-WEND-Schleifen sind aber nicht zulässig. + + +Beispiel : 10 DIM name$ (5) + 20 FOR i = 1 TO 5 + 30 PRINT "Bitte geben Sie den " + STR$ (i) + #right#+ ". Namen ein:"; + 40 INPUT name$ (i) + 50 NEXT i + + + Es werden die fünf Elemente des Feldes 'name$' eingelesen. + +Vergleiche : NEXT-, WHILE-, IF-Anweisungen + + + +Funktion : FRE + +Zweck : Ermittlung des verfügbaren Speicherplatzes + +Syntax : FRE (<num. Ausdruck>) + FRE (<TEXT-Ausdruck>) + +Erklärung : Die Funktion liefert die Anzahl der freien Bytes. + FRE veranlaßt außerdem ein 'collect heap garbage' (EUMEL- + Systemprozedur). + + Das Ergebnis der Funktion wird als REAL geliefert. + Der Argument-Ausdruck ist ein Dummy-Argument (hat keinen + Einfluß auf den gelieferten Wert). + +Hinweis : Bei der EUMEL M+ Version wird ein korrektes Ergebnis geliefert + (vgl.'storage info'). + + +Beispiel : 10 PRINT FRE (0) + Ausgabe (z.B.): 5324800 + + + +Anweisungsbestandteil : GO + +Siehe GOSUB und GOTO + + + +Anweisung : GOSUB + +Zweck : Unterprogramm-Aufruf + +Syntax : GOSUB <Zeilennummer> + +Erklärung : <Zeilennummer>: INT-Konstante + Statt GOSUB darf auch GO #ib(3)#SUB#ie(3)# geschrieben werden. + + Die Programmausführung wird in der Zeile mit der angegebenen + Zeilennummer fortgesetzt. Die Zeile mit der Zeilennummer muß im + Programm existieren. + Wird im weiteren Programmablauf die Anweisung RETURN gefunden, + so wird hinter dem letzten abgearbeiteten GOSUB die Programm + ausführung fortgesetzt. + GOSUB dient zum Aufruf von #on("iUnterprogrammen#off("i, die von mehr als + einer Stelle im Programm (und auch in anderen Unterprogrammen) + aufgerufen werden können. + +Hinweis : Es wird empfohlen, Unterprogramme im Programm deutlich als solche + zu kennzeichnen und (durch END, STOP oder GOTO) sicherzustel + len, daß nur mit GOSUB zu ihnen verzweigt wird, da es sonst leicht + zu der (Laufzeit-) Fehlermeldung "RETURN ohne GOSUB" kommen + kann. + + +Beispiel : 140 GOSUB 10000 'Zeige Uhrzeit + . + . + 370 GOSUB 10000 'Zeige Uhrzeit + 9990 END + 10000 REM Unterprogramm Zeige Uhrzeit + 10010 PRINT "Es ist " + TIME$ + " Uhr" + 10020 RETURN + + +Vergleiche : RETURN-, ON-, GOTO- Anweisungen + + + +Anweisung : GOTO + +Zweck : Sprung zu einer angegebenen Zeile + +Syntax : GOTO <Zeilennummer> + +Erklärung : <Zeilennummer>: INT-Konstante + Statt GOTO darf auch GO #ib(3)#TO#ie(3)# geschrieben werden. + + Die Programmausführung wird in der Zeile mit der angegebenen + Zeilennummer fortgesetzt. Die Zeile mit der Zeilennummer muß im + Programm existieren. + + +Beispiel : 10 INPUT "Monat (1-12)", monat% + 20 IF monat% < 1 OR monat% > 12 THEN GOTO 10 + + +Vergleiche : ON-, IF-, GOSUB- Anweisungen + + + +Funktion : HEX$ + +Zweck : Erzeugung der hexadezimalen Darstellung einer Zahl als Text + +Syntax : HEX$ (<INT-Ausdruck>) + +Erklärung : Die Funktion liefert die hexadezimale (Zweierkomplement-) Darstel + lung der Zahl, die sich aus dem INT-Ausdruck ergibt. + + +Beispiel : 10 PRINT HEX$ (10000) + Ausgabe: 2710 + +Vergleiche : OCT$-Funktion + + + +Anweisung : IF + +Zweck : Sprung zu einer angegebenen Zeile + +Syntax : IF <Bedingung> + #right#[,] #ib(3)#THEN#ie(3)# <Anweisung(en)>|<Zeilennummer> + #right#[ [,] #ib(3)#ELSE#ie(3)# <Anweisung(en)>|<Zeilennummer>] + IF <Bedingung> [,] GOTO <Zeilennummer> + #right#[ [,] ELSE <Anweisung(en)>|<Zeilennummer>] + +Erklärung : <Bedingung> : numerischer Ausdruck + <Anweisung(en)>: Eine oder mehrere BASIC-Anweisungen, wobei + mehrere wie gewohnt durch ':' zu trennen sind + <Zeilennummer> : INT-Konstante + Statt GOTO darf auch GO TO geschrieben werden. + + Anhand der Bedingung wird entschieden, ob die Abarbeitung des + Programms mit dem THEN- oder ELSE-Zweig fortgesetzt werden + soll. Mit dem THEN-Zweig wird das Programm fortgesetzt, wenn die + Bedingung erfüllt ist (, d.h. der numerische Ausdruck ungleich null + ist). Im anderen Fall (Bedingung nicht erfüllt, numerischer Ausdruck + gleich null) wird das Programm mit dem ELSE-Teil fortgesetzt. Ist + kein ELSE-Teil angegeben, so wird die Abarbeitung des + Programmes in der folgenden #on("iZeile#off("i (nicht nach ':') fortgesetzt. + + Sind statt Anweisungen Zeilennummern nach THEN oder ELSE + angegeben, so entspricht dies einem GOTO (s.d.) zu diesen Zeilen + nummern. + + +Hinweis : Auch eine IF-Anweisung muß in #on("ieiner#off("i Programmzeile stehen. + + +Beispiel : 10 IF a >= b THEN IF a > b THEN + #right#PRINT "a größer b" ELSE PRINT "a gleich b" + #right#ELSE PRINT "a kleiner b" + + + Das Beispiel zeigt, daß bei geschachtelten IF-Anweisungen die + ELSE-Teile immer auf das letzte vorhergehende IF bezogen werden, + für das noch kein ELSE-Teil gefunden wurde. + + + +Vergleiche : GOTO-, GOSUB-, ON-Anweisungen + + + +Operator : IMP + +Siehe Kapitel 4.4. (Operatoren) + + + +Funktion : INKEY$ + +Zweck : Holen eines Zeichens von der Tastatur + +Syntax : INKEY$ + +Erklärung : Die Funktion liefert ein Textzeichen aus dem Tastaturzeichenpuffer. + Wurde kein Zeichen eingegeben, so wird ein Leertext (niltext) gelie + fert. + Die gelieferten Zeichen erscheinen nicht auf dem Bildschirm. + + +Beispiel : 10 REM Schreibmaschine + 20 LET a$ = INKEY$ + 30 IF ASC (a$) = 27 THEN STOP + 40 PRINT a$; + 50 GOTO 20 + + + Die eingegebenen Zeichen werden ausgegeben. Abbruch mit ESC. + +Vergleiche : INPUT$-Funktion, INPUT-Anweisung + + + +Anweisung : INPUT + +Zweck : Einlesen von Daten von der Tastatur + +Syntax : INPUT [;] [<Eingabeaufforderung> ,|; ][ #ib(3)#EOF#ie(3)# + <Zeilennummer>] + #right#<Variable> [, <Variable> ] [...] + +Erklärung : <Eingabeaufforderung>: TEXT-Konstante + <Zeilennummer>: INT-Konstante + <Variable>: Variable, der der eingelesene Werte + zugewiesen werden soll + + Mit der INPUT-Anweisung werden Daten zur Laufzeit des + Programms von der Tastatur in Variablen eingelesen. + + Folgt dem INPUT-Statement ein Semikolon, so wird nach + Beendigung der Eingabe kein Zeilenwechsel vorgenommen. + + Fehlt die <Eingabeaufforderung>, so wird "? " als Eingabe + aufforderung ausgegeben. + Folgt der ein Semikolon, so wird "? " noch zusätzlich ausge + geben. Bei einem Komma wird dieser Standard-Prompt unter + drückt. + + Folgt der <Eingabeaufforderung> die Zeichenfolge 'EOF', so wird + bei Eingabe eines Leertextes zu der nach 'EOF' angegebenen + Zeilennumer verzweigt. + + Sollen mehrere Variablen eingelesen werden, so muß der Benutzer + auch entsprechend viele Daten (durch Kommata getrennt) zur Verfü + gung stellen. + + Wird nichts eingegeben beziehungsweise nur die richtige Anzahl von + Kommata, so wird den entsprechenden Variablen 0, 0.0 bzw. 'niltext' + zugewiesen. + + Bei der Eingabe für eine Textvariable können alle Zeichen (außer + Steuerzeichen) eingegeben werden. Beginnt eine Eingabe mit dem + Anführungszeichen oder endet sie damit, dann muß sie auch damit + enden beziehungsweise beginnen. Diese beiden Anführungszeichen + werden nicht mit zugewiesen. Innerhalb dieser Texteingabe dürfen + Anführungszeichen stehen, aber keine Kommata. + + Eingaben für numerische Variablen müssen in der für Konstanten + üblichen Schreibweise erfolgen. Vorzeichen sind allerdings zusätzlich + erlaubt. + + Vor Zuweisung der eingegebenen Werte an die Variablen werden + Anzahl und Typ(en) und die Anzahl überprüft. + Dabei können folgende Fehlerfälle auftreten: + - "falscher Typ": + Es wurde ein Text statt einer Zahl eingegeben, es wurde ein REAL + statt eines INTs eingegeben oder eine Texteingabe ist fehlerhaft. + - "zu wenig Daten" + - "zu viele Daten" + - "Überlauf": + Es wurde eine zu große (oder zu kleine) Zahl eingegeben. + + Kommt es zu einem Fehler, dann wird nach der Meldung "?Eingabe + wiederholen ! (<Fehlerbeschreibung>)" die Eingabe zum Editieren + angeboten. + +Hinweis : Bei Eingabe von 'ESC k' kann die letzte Eingabezeile zum Editieren + zurückgeholt werden. + + Die Eingabe kann mit der Systemprozedur 'sysin' aus einer Datei + erfolgen. Aus der Eingabedatei wird für jedes INPUT-Statement eine + Zeile eingelesen. Die Ausgabe der Eingabeaufforderung und der + Zeilenwechsel nach der Eingabe werden unterdrückt. Sind die + Eingabedaten fehlerhaft, so wird das Programm mit 'errorstop' + abgebrochen. + + Wird die Ausgabe mit 'sysout' umgeleitet, so werden die Eingabe + aufforderung, die Eingabezeichenfolge und der Zeilenwechsel nach + der Eingabe auf den Bildschirm und in die Ausgabedatei ausgegeben, + auch dann, wenn der Text der Eingabe aus einer Datei eingelesen + wurde. + + +Beispiel : 1990 INPUT "Name, Vorname, Alter"; + #right#name$, vorname$, alter% + + +Vergleiche : INKEY$-, INPUT$-Funktionen + + + +Funktion : INPUT$ + +Zweck : Holen einer Zeichenfolge von der Tastatur + +Syntax : INPUT$ (<Anzahl Zeichen>) + +Erklärung : <Anzahl Zeichen>: INT-Ausdruck + + Die Funktion liefert eine Folge von <Anzahl Zeichen> Textzeichen + aus dem Tastaturzeichenpuffer. Enthält der Puffer nicht alle ge + wünschten Zeichen, so wird auf weitere Zeichen von der Tastatur + gewartet. + Die gelieferten Zeichen erscheinen nicht auf dem Bildschirm. + + +Beispiel : 10 PRINT "Bitte drei Zeichen eingeben !" + 20 LET a$ = INPUT$ (3) + 30 PRINT "Danke schön !" + + +Vergleiche : INKEY$-Funktion, INPUT-Anweisung + + + +Funktion : INSTR + +Zweck : Suchen einer Zeichenfolge in einer anderen + +Syntax : INSTR ( [<Startposition>,] <TEXT-Ausdruck1>, + #right#<TEXT-Ausdruck 2>) + +Erklärung : <Startposition>: INT-Ausdruck + + Die Funktion liefert die Position, ab der der TEXT-Ausdruck 2 das + erste Mal im TEXT-Ausdruck 1 vorkommt. + Die Position wird als INT geliefert. + + +Beispiel : 10 LET a$ = "hallihallo" + 20 LET b$ = "all" + 30 PRINT INSTR (a$, b$); INSTR (5, a$, b$) + Ausgabe: 2 7 + + + +Funktion : INT + +Zweck : Ermittlung der nächstkleineren ganzen Zahl + +Syntax : INT (<REAL-Ausdruck>) + +Erklärung : Die Funktion liefert die größte ganze Zahl, für die gilt: + n kleiner gleich <REAL-Ausdruck>. + Bei positiven Werten bedeutet das, daß die Nachkommastellen abge + schnitten werden. + Das Ergebnis wird als REAL geliefert. + + +Beispiel : 10 PRINT INT (11.74); INT (-11.74) + Ausgabe: 11 -12 + +Vergleiche : CINT-, FIX-Funktionen + + + +Anweisung : KILL + +Zweck : Löschen einer Datei in der Task + +Syntax : KILL <Dateiname> + +Erklärung : <Dateiname>: TEXT-Ausdruck + Die Datei <Dateiname> wird (ohne Nachfrage) gelöscht. + + +Beispiel : 2110 KILL "Scratchdatei" + + + + +Funktion : LEFT$ + +Zweck : Erzeugung eines Teiltextes aus einem anderen Text + +Syntax : LEFT$ (<TEXT-Ausdruck>, <Anzahl Zeichen>) + +Erklärung : <Anzahl Zeichen>: INT-Ausdruck + + Die Funktion liefert die ersten <Anzahl Zeichen> Textzeichen des + TEXT-Ausdrucks. + + +Beispiel : 10 LET a$ = "hallihallo" + 20 PRINT LEFT$ (a$, 4) + Ausgabe: hall + +Vergleiche : MID$-, RIGHT$-Funktionen, LSET-, MID$-, RSET- + Anweisungen + + + +Funktion : LEN + +Zweck : Ermittlung der Länge eines Textes + +Syntax : LEN (<TEXT-Ausdruck>) + +Erklärung : Die Funktion liefert die Anzahl der im TEXT-Ausdruck enthaltenen + Zeichen (also die Länge des Textes). Die Länge wird als INT + geliefert. + Ein Leertext (niltext, "") hat die Länge null. + + +Beispiel : 10 LET a$ = "hallihallo" + 20 PRINT LEN (a$) + Ausgabe: 10 + + + +Anweisung : LET + +Zweck : Zuweisung eines Wertes an eine Variable + +Syntax : [LET] <Variable> = <Ausdruck> + +Erklärung : Die LET-Anweisung ermöglicht das Zuweisen von Werten an Variab + len (dazu gehören auch die Elemente von Feldern). + + Das Schlüsselwort LET ist optional, d.h. eine Zuweisung wird auch + ohne dieses Schlüsselwort erkannt. + + #on("iZuweisung an TEXT-Variablen:#off("i + LET <TEXT-Variable> = <TEXT-Ausdruck> oder <num. + Konstante> + Die numerische Konstante wird automatisch in einen TEXT umge + wandelt (vgl. STR$-Funktion) + + #on("iZuweisung an INT-Variablen:#off("i + LET <INT-Variable> = <num. Ausdruck> + Ist der numerische Ausdruck ein REAL-Ausdruck, so wird automa + tisch nach INT konvertiert (vgl. CINT-Funktion). + + #on("iZuweisung an REAL-Variablen:#off("i + LET <REAL-Variable> = <num. Ausdruck> + Ist der numerische Ausdruck ein INT-Ausdruck, so wird automatisch + nach REAL konvertiert (vgl. CDBL-Funktion). + + +Beispiel : 10 LET t$ = "murmel marmel" + 20 LET t$ = 1245.3 'wie "1245.3" + 30 LET i% = 852 + 40 LET i% = 12.73 'aufgerundet: 13 + 50 LET r = 564 'wie 564. + 60 LET r = 157.36 + + + + +Anweisung : LINE INPUT + +Zweck : Einlesen einer Eingabe von der Tastatur in eine TEXT-Variable + +Syntax : LINE INPUT [;] [<Eingabeaufforderung>;] + #right#<TEXT-Variable> + +Erklärung : Die LINE INPUT-Anweisung ermöglicht das Einlesen von Eingaben + in TEXT-Variablen, aber im Gegensatz zu INPUT ohne Beachtung + von Trennzeichen (z.B. ","). + + Steht direkt nach LINE INPUT ein Semikolon, so wird nach Beendi + gung der Eingabe der Zeilenwechsel unterdrückt. + + Der eingegebene Text wird (bis auf das CR-Zeichen) der TEXT- + Variablen zugewiesen. + + +Beispiel : 2110 LINE INPUT "Name: ";name$ + + + Der Benutzer könnte nun auch folgendes eingeben: + Neumann, Alfred E. + +Vergleiche : INPUT-Anweisung + + + +Funktion : LOG + +Zweck : Berechnung des natürlichen Logarithmus einer Zahl + +Syntax : LOG (<REAL-Ausdruck>) + +Erklärung : Die Funktion liefert den natürlichen Logarithmus des Wertes des + REAL-Ausdrucks. + Bei nicht-positiven Werten kommt es zu einem Fehler in der + EUMEL-Prozedur 'log2'. + Das Ergebnis der Funktion wird als REAL geliefert. + + +Beispiel : 10 PRINT LOG (10.0) + Ausgabe: 2.302585 + +Vergleiche : EXP-Funktion (Komplementärfunktion) + + + +Funktion : LPOS + +Zweck : Ermittlung der aktuellen Druckspalte + +Syntax : LPOS (<num. Ausdruck>) + +Erklärung : Geliefert wird die Nummer der Spalte (als INT), in die das nächste + nächste Zeichen mit LPRINT ausgegeben wird. Die Spalte ganz links + hat die Nummer 1. + Der Argument-Ausdruck ist ein Dummy-Argument (hat keinen + Einfluß auf den gelieferten Wert). + + +Beispiel : 3010 IF LPOS (0) > 65 THEN LPRINT + 3020 LPRINT name$ + + + Falls die Druckposition hinter Spalte 65 liegt, wird eine neue Druck + zeile begonnen. + +Vergleiche : LPRINT-Anweisung, TAB-, POS-Funktion + + + +Anweisung : LPRINT + +Zweck : Ausgabe in eine Druckdatei + +Syntax : LPRINT [#ib(3)#USING#ie(3)# <Format> ;] + #right#[ #ib(3)#TAB#ie(3)# (<Spalte>) | , | ; | <Ausdruck> ] [...] + +Erklärung : <Format> : TEXT-Ausdruck für USING (vgl. PRINT) + <Spalte> : INT-Ausdruck (vgl. PRINT) + <Ausdruck>: TEXT-Ausdruck oder numerischer Ausdruck + + Die LPRINT-Anweisung arbeitet wie PRINT (siehe dort), mit dem + Unterschied, daß LPRINT die Zeichen nicht auf den Bildschirm, son + dern in eine Datei mit dem Namen "BASIC LPRINT OUTPUT" + ausgibt. Diese Datei wird automatisch eingerichtet, falls sie noch + nicht existiert. Ist sie schon vorhanden, so werden die auszugeben + den Zeichen am Ende der Datei angefügt. + Nach oder bei Ablauf des Programms kann die Datei (evtl. nach + vorheriger Aufbereitung durch Textverarbeitungsprogramme) mit + 'print', wie im EUMEL-System üblich, an den Drucker geschickt + werden. Der Benutzer ist selbst dafür verantwortlich, daß er die + Druckdatei, sofern die Daten nicht mehr benötigt werden, vor einem + neuen Programmlauf leert oder löscht. Versäumt er dies, so bleiben + die alten Daten in der Druckdatei, und die neuen Ausgaben werden + hinten angefügt. Das Löschen der Druckdatei kann zum Beispiel + durch das BASIC-Programm mit der KILL-Anweisung erreicht + werden. + + Die Art der Ausgabe und die Syntax ist sonst analog zur PRINT- + Anweisung (siehe Erläuterungen dort). + + +Beispiel : 2110 LPRINT "Dieser Text geht in die Druckdatei" + 2120 LPRINT TAB (12); "Datum: " DATE$ + 2130 LPRINT 1, 2, 3 + + +Vergleiche : PRINT-Anweisung, LPOS-Funktion + + + +Anweisung : LSET + +Zweck : Ersetzen von Zeichen eines Textes von links her + +Syntax : LSET <TEXT-Variable> = <TEXT-Ausdruck> + +Erklärung : Das Ergebnis des TEXT-Ausdrucks wird, links beginnend, in der + TEXT-Variablen eingesetzt. Es werden höchstens so viele Zeichen + ersetzt, wie bisher schon in der Variablen vorhanden waren, das heißt + die Länge des Textes in der Variablen ändert sich nicht. + + +Beispiel : 210 LET a$ = "12345" + 220 LSET a$ = "ABCDEFG" + 230 PRINT a$, + 240 LSET a$ = "abc" + 250 PRINT a$ + Ausgabe: ABCDE abcDE + +Vergleiche : MID$-, RSET-Anweisungen, LEFT$-, MID$-, RIGHT$-Funk + tionen + + + +Anweisung : MID$ + +Zweck : Ersetzen von Zeichen innnerhalb eines Textes + +Syntax : MID$ (<TEXT-Variable>, <Startposition> + #right#[, <Anzahl Zeichen>] ) = <TEXT-Ausdruck> + +Erklärung : <Startposition> : INT-Ausdruck + <Anzahl Zeichen>: INT-Ausdruck + + Das Ergebnis des TEXT-Ausdrucks wird, bei <Startposition> + beginnend, in der TEXT-Variablen eingesetzt. Es werden höch + stens LEN <TEXT-Variable> Textzeichen ersetzt. Ist keine + <Anzahl Zeichen> angegeben, so werden so viele Zeichen des + TEXT-Ausdrucks wie möglich in der TEXT-Variablen eingetragen. + Außerdem gilt: Es wird nicht über das bisherige Ende des Variablen + inhalts ersetzt, das heißt die Länge des Textes in der Variablen + ändert sich nicht. + + +Beispiel : 210 LET a$ = "12345" + 220 MID$ (a$, 3) = "ABCDEFG" + 230 PRINT a$, + 240 MID$ (a$, 2, 1) = "abc" + 250 PRINT a$ + Ausgabe: 12ABC 1aABC + +Vergleiche : LEFT$-, MID$-, RIGHT$-Funktionen, LSET-, RSET- + Anweisungen + + + +Funktion : MID$ + +Zweck : Erzeugung eines Teiltextes aus einem anderen Text + +Syntax : MID$ (<TEXT-Ausdruck>, + #right#<Startposition> [, <Anzahl Zeichen>]) + +Erklärung : <Startposition> : INT-Ausdruck + <Anzahl Zeichen>: INT-Ausdruck + + Die Funktion liefert höchstens <Anzahl Zeichen> Textzeichen des + TEXT-Ausdrucks von Position <Startposition> an. + Wird <Anzahl Zeichen> nicht angegeben, so werden alle Zeichen + ab Startposition geliefert. + Werden rechts von <Startposition> keine Zeichen mehr gefunden + oder ist <Anzahl Zeichen> gleich null, so wird ein Leertext geliefert. + + +Beispiel : 10 LET a$ = "hallihallo" + 20 PRINT MID$ (a$, 4, 4), + 30 PRINT MID$ (a$, 6) + Ausgabe: liha hallo + +Vergleiche : LEFT$-, RIGHT$-Funktionen, LSET-, MID$-, RSET- + Anweisungen + + + +Funktion : MKD$, MKI$ + +Zweck : Codierung von Zahlenwerten in Texte + +Syntax : MKD$ (<REAL-Ausdruck>) + MKI$ (<INT-Ausdruck>) + +Erklärung : Mit MKD$ und MKI$ können INTs und REALs zu Texten codiert + werden. + + Die Funktion MKD$ liefert einen 8 Zeichen langen TEXT, der den + Wert des REAL-Ausdrucks codiert enthält. + Vergleichbar arbeitet MKI$, das einen 2 Zeichen langen TEXT liefert, + der den Wert des INT-Ausdrucks darstellt. + + Mit MKD$ und MKI$ codierte Werte können mit CVD und CVI (s.d.) + wieder decodiert werden. + + +Beispiel : 10 zahl$ = MKD$ (3.1415) + 20 PRINT CVD (zahl$) + Ausgabe: 3.1415 + +Vergleiche : CVD-, CVI-Funktionen + + + +Operator : MOD + +Siehe Kapitel 4.4. (Operatoren) + + + +Anweisung : NAME + +Zweck : Umbenennen einer Datei + +Syntax : NAME <alter Name> AS <neuer Name> + +Erklärung : <alter Name>: TEXT-Ausdruck + <alter Name>: TEXT-Ausdruck + + NAME benennt die Datei <alter Name> in <neuer Name> um. + + +Beispiel : 10 NAME "Käufer" AS "Kunden" + + + + +Anweisung : NEXT + +Zweck : Markierung des Endes einer FOR-Schleife + +Syntax : NEXT [<num. Variable>] [, <num. Variable>] [...] + +Erklärung : NEXT markiert das Ende einer FOR-Schleife (vergleiche FOR- + Anweisung). + + Wird keine Variable angegeben, so bezieht sich das NEXT auf das + letzte textuell vorhergehende FOR. + Wird eine Laufvariable angegeben, so muß sie mit der im letzten + FOR verwendeten Laufvariable übereinstimmen. + Werden mehrere Variablen angegeben, so werden durch die + NEXT-Anweisung mehrere FOR-Schleifen abgeschlossen. + Beachten Sie, daß FOR-Schleifen sich nicht überschneiden dürfen, + sondern nur Schachtelungen zulässig sind. Es kommt daher auf die + Reihenfolge der Variablen bei den NEXT-Anweisungen an. Die + letzte (innerste) FOR-Schleife muß als erste wieder mit dem zuge + hörigen NEXT abgeschlossen werden. + +Vergleiche : FOR-, WHILE-Anweisungen + + + +Operator : NOT + +Siehe Kapitel 4.4. (Operatoren) + + + +Funktion : OCT$ + +Zweck : Erzeugung der oktalen Darstellung einer Zahl als Text + +Syntax : OCT$ (<INT-Ausdruck>) + +Erklärung : Die Funktion liefert die oktale (Zweierkomplement-) Darstellung der + Zahl, die sich aus dem INT-Ausdruck ergibt. + + +Beispiel : 10 PRINT OCT$ (10000) + Ausgabe: 23420 + +Vergleiche : OCT$-Funktion + + + +Anweisung : ON + +Zweck : Ausführung eines "berechneten" Sprungs oder Unterprogramm- + Aufrufs + +Syntax : ON <Sprungziel Nr.> GOTO | GOSUB + #right#<Zeilennummer> [, <Zeilennummer>] [...] + +Erklärung : <Sprungziel Nr.>: INT-Ausdruck + <Zeilennummer> : INT-Konstante + + ON ermöglicht die Verzweigung des Programms an eine von mehre + ren Stellen abhängig vom Ergebnis eines INT-Ausdrucks. + Gelangt das Programm an eine ON-Anweisung, dann wird zunächst + der Wert des INT-Ausdrucks berechnet. Dieses Ergebnis bildet dann + die Nummer n des Sprungziels. Danach wird zur n-ten Zeilen + nummer, die nach GOTO beziehungsweise GOSUB steht, verzweigt. + Die maximale Anzahl von Zeilennummern, die nach GOTO oder + GOSUB angegeben werden dürfen, ist 512. + Nimmt <Sprungziel Nr.> einen Wert an, zu dem keine Zeile in der + Liste gefunden wird (z.B. Werte kleiner gleich null oder Werte größer + als die Anzahl der angegebenen Zeilennummern), so wird das Pro + gramm mit der der ON-Anweisung folgenden Programmzeile fortge + setzt. + + Statt GOTO und GOSUB darf auch GO TO beziehungsweise + GO SUB geschrieben werden. + +Hinweis : Die ON-Anweisung muß in #on("ieiner#off("i Programmzeile stehen. + + +Beispiel : 260 INPUT "Menüpunkt 1, 2 oder 3", a + 270 ON VAL (a) GOTO 300, 400, 500 + 280 GOTO 260 + 300 PRINT "Menüpunkt 1" + . + . + 400 PRINT "Menüpunkt 2" + . + . + 500 PRINT "Menüpunkt 3" + + + Entsprechend der Eingabe wird nach 300, 400 oder 500 verzweigt. + Bei Fehleingaben wird Zeile 280 ausgeführt. + +Vergleiche : GOSUB-, GOTO-, IF-Anweisungen + + + +Anweisung : OPTION BASE + +Zweck : Festlegung des kleinsten Wertes für Feldindizes + +Syntax : OPTION BASE 0|1 + +Erklärung : OPTION BASE legt fest, ob die nachfolgend dimensionierten Felder + Elemente mit dem Index 0 erhalten, oder ob der niedrigste Index 1 + ist. Voreingestellt ist OPTION BASE 0. + +Hinweis : Der niedrigste Feldindex kann für jedes Feld individuell eingestellt + werden. Die OPTION BASE-Anweisung gilt für alle Felder, deren + Dimensionierung ihr textuell nachfolgen. Eine erneute OPTION + BASE-Anweisung kann dann die Untergrenze für die #on("iihr#off("i folgenden + Dimensionierungen festlegen. + + +Beispiel : 10 DIM a (100) 'Indizes 0-100 + 20 OPTION BASE 1 + 30 b$ (3) = "hallo" 'Indizes 1-10 + 40 DIM a% (5) 'Indizes 1-5 + 50 OPTION BASE 0 + 60 DIM c% (9) 'Indizes 0-9 + 70 LET d (4) = 12.3 'Indizes 0-10 + + +Vergleiche : DIM-Anweisung + + + +Operator : OR + +Siehe Kapitel 4.4. (Operatoren) + + + +Funktion : POS + +Zweck : Ermittlung der aktuellen Cursorspalte + +Syntax : POS (<num. Ausdruck>) + +Erklärung : Geliefert wird die Nummer der Spalte (als INT), in der sich der Cursor + auf dem Bildschirm befindet. Die Spalte ganz links hat die Num + mer 1. + Der Argument-Ausdruck ist ein Dummy-Argument (hat keinen + Einfluß auf den gelieferten Wert). + + +Beispiel : 10 CLS + 20 PRINT "testtext"; + 30 PRINT POS (0) + Ausgabe: testtext 9 + + +Vergleiche : CSRLIN-, LPOS-Funktionen + + + +Anweisung : PRINT + +Zweck : Ausgabe auf den Bildschirm + +Syntax : PRINT [#ib(3)#USING#ie(3)# <Format> ;] + #right#[ #ib(3)#TAB#ie(3)# (<Spalte>) | , | ; | <Ausdruck> ] [...] + +Erklärung : <Format> : TEXT-Ausdruck für USING (s. u.) + <Spalte> : INT-Ausdruck (s. u.) + <Ausdruck>: TEXT-Ausdruck oder numerischer Ausdruck, der + ausgegeben werden soll. + + PRINT dient der Ausgabe von Zeichen auf dem Bildschirm. + Numerische Werte werden mit sieben signifikanten Ziffer ausgege + ben. Bei Exponentendarstellung werden für den Exponent maximal 3 + Ziffern ausgegeben. Hinter allen numerischen Werten und vor posi + tiven numerischen Werten wird jeweils ein Leerzeichen ausgegeben. + + TAB bewirkt eine Positionierung des Cursors auf die angegebene + Spalte (die Spalte ganz links hat die Nummer 1). Ist die Spaltenzahl + größer als die mit WIDTH eingestellte Ausgabebreite, so wird auf die + Spalte mit der Nummer Spalte MODULO Ausgabebreite positioniert. + Eine Spaltennummer kleiner gleich null bewirkt eine entsprechende + Warnung. + Ist die Spalte mit der angegebenen Nummer in der aktuellen Zeile + bereits überschritten, dann wird auf die nächste Zeile positioniert. + + Ein Semikolon bewirkt, daß der Cursor an der gerade erreichten + Position bleibt. + + Ein Komma bewirkt die Positionierung auf die nächste gültige Spal + te, für deren Nummer gilt: Nummer MODULO 16 ist 1. + Das Komma dient also der Ausgabe in 16 Zeichen breiten Zonen. + + Endet die PRINT-Anweisung mit TAB (<Spalte>), einem Komma + oder einem Semikolon, dann wird kein Zeilenvorschub ausgelöst. + + #onbold#USING + Der EUMEL-BASIC-Compiler unterstützt auch die PRINT + USING-Anweisung für formatierte Ausgaben. + Der nach dem Wort USING angegebene TEXT-Ausdruck spezifi + ziert das Ausgabeformat für eine PRINT USING-Anweisung. + + Formatierung von Texten: + "!": Nur das erste Zeichen einer Zeichenfolge wird ausgegeben + "\n Leerzeichen\": Es werden die 2 + n ersten Zeichen einer + Zeichenfolge ausgegeben + "&": Alle Zeichen einer Zeichenfolge werden ausgegeben + + Formatierung von Zahlen: + "\#": bezeichnet eine Ziffernposition + ".": Position des Dezimalpunkts + "+": (vor oder nach Zahlen) Ausgabe des Vorzeichens + "-": (nach Zahlen) gegebenenfalls Ausgabe von "-" hinter der + Zahl + "**": Führende Leerstellen werden mit Sternchen aufgefüllt; wirkt + außerdem wie "\#\#". + "$$": Es wird ein Dollarzeichen links vor der formatierten Zahl ausgegeben; + wirkt außerdem wie "\#\#". + "**$": Führende Leerstellen werden mit Sternchen ausgefüllt und direkt vor + der formatierten Zahl wird ein Dollarzeichen ausgegeben; wirkt + außerdem wie "\#\#\#". + ",": (vor Dezimalpunkt) Unterteilung der Vorkommastellen in Dreier + gruppen mittels Komma + "^^^^": Position des Exponenten + "_": Ein Zeichen, das einem Unterstreichungsstrich folgt, wird unverändert + ausgegeben + + Ist der Format-Ausdruck fehlerhaft, so kommt es zum Fehler "USING- + Format fehlerhaft". + Überschreitet eine auszugebende Zahl in irgendeiner Hinsicht die im + Format-Ausdruck für sie vorgesehene Stellenzahl, so wird das Zeichen "%" + ausgegeben, um den Fehler anzuzeigen. + + +Hinweis : 1. PRINT (und PRINT USING) richtet sich bei allen Ausgaben nach + der mit WIDTH eingestellten Ausgabebreite. + 2. Alle Ausgaben von PRINT können mit der Systemprozedur + 'sysout' in eine Datei umgeleitet werden. Dann wird nichts auf + das Terminal ausgegeben. + 3. Das Verhalten beim Erreichen der letzten Bildschirmzeile kann + mit der Prozedur 'basic page' gesteuert werden. Vergleiche + hierzu Kapitel 5, "Steuerung der Bildschirmausgabe". + + +Beispiel : 10 PRINT "hallo", 2 ^ 32 TAB (33) "Ende"; + + Ausgabe: hallo 4.294967E+09 Ende + Position: 1234567890123456789012345678901234567890 + + +Vergleiche : WRITE-, LPRINT-Anweisungen, POS-, CSRLIN-, SPC- + Funktionen + + + +Anweisung : RANDOMIZE + +Zweck : Festlegung eines Anfangswertes für den Zufallszahlengenerator + +Syntax : RANDOMIZE [<num. Ausdruck>] + +Erklärung : Mit RANDOMIZE erhält der Zufallszahlengenerator einen bestimmten + Startwert. + Ist kein numerischer Ausdruck angegeben, so wird während des + Programmlaufs die Meldung "Startwert des Zufallszahlen + generators ?" ausgegeben und ein Startwert eingelesen. + + Wird der Zufallszahlengenerator immer mit dem gleichen Wert gestar + tet, so liefert er auch immer die gleichen Zufallszahlen. Soll er immer + verschiedene Werte liefern, so kann er zum Beispiel mit der System + uhr auf zufällige Startwerte gesetzt werden (RANDOMIZE TIMER). + + +Beispiel : 10 RANDOMIZE 4711 + 20 FOR i = 1 TO 5 + 30 PRINT INT (RND * 10); + 40 NEXT i + Ausgabe: 5 6 2 9 6 + +Vergleiche : RND-Funktion + + + +Anweisung : READ + +Zweck : Auslesen von Daten aus DATA-Anweisungen + +Syntax : READ <Variable> [, <Variable>] [...] + +Erklärung : <Variable>: numerische Variable oder TEXT-Variable + + Die READ-Anweisung liest die nächsten Elemente aus der aktuellen + DATA-Anweisung (s.d.) in die angegebenen Variablen ein. + + In TEXT-Variablen können sowohl "quoted strings" als auch "un + quoted strings" (vgl. DATA-Anweisung) eingelesen werden. + In numerische Variablen können dagegen nur "unquoted strings" + eingelesen werden. Außerdem müssen die Zeichen des "unquoted + string" eine gültige Darstellung einer numerischen Konstanten (even + tuell mit Vorzeichen) sein. Sind diese Bedingungen nicht erfüllt, so + kommt es bei der Ausführung des Programms zu entsprechenden + Fehlern. + + Eine READ-Anweisung kann Daten aus vorangehenden und nach + folgenden DATA-Anweisungen lesen. + Alle DATA-Anweisungen eines Programms bilden zusammen einen + großen sequentiellen Speicher, auf den mit READ der Reihe nach + zugegriffen wird. Intern wird ein sogenannter READ-DATA-Zeiger + geführt, der immer auf das nächste auszulesende Element zeigt. + + Die RESTORE-Anweisung (s.d.) ermöglicht es, den READ-DATA- + Zeiger auf das erste Element einer bestimmten DATA-Zeile zu + setzen. + + Sind keine Daten mehr für READ vorhanden, so wird die Ausführung + des Programms mit der Fehlermeldung "Keine Daten mehr für + READ" abgebrochen. + + +Beispiel : 2020 PRINT "Stadt", "Land", "Fluß" + 2030 READ stadt$, land$, fluß$ + 2040 PRINT stadt$, land$, fluß$ + . + 5000 DATA Köln, Bundesrepublik Deutschland, Rhein + + +Vergleiche : DATA-, RESTORE-Anweisungen + + + +Anweisung : REM + +Zweck : Ermöglicht das Einfügen von Kommentaren in ein Programm + +Syntax : REM <Zeichenfolge> + +Erklärung : <Zeichenfolge>: Beliebige Folge von Zeichen + + Wird eine REM-Anweisung gefunden, so wird der Rest der Pro + grammzeile nicht weiter beachtet. Die Compilierung wird in der fol + genden Zeile fortgesetzt. + Es empfielt sich, von Kommentarzeilen möglichst oft Gebrauch zu + machen, weil sie den Programmtext dokumentieren und strukturieren. + +Hinweis : Nach REM können keine weiteren Anweisungen mehr in einer Pro + grammzeile stehen, da sie nicht übersetzt werden. Auch der Doppel + punkt wird nach REM nicht beachtet. + + +Beispiel : 1000 REM Ausgabe des Feldes + 1010 FOR i = 1 TO feldgroesse% + 1020 PRINT "Eintrag"; i; feld (i) + 1030 NEXT i + + + +Anweisung : RESTORE + +Zweck : Setzen des READ-DATA-Zeigers auf den Anfang einer angegebe + nen Zeile + +Syntax : RESTORE [<Zeilennummer>] + +Erklärung : <Zeilennummer>: INT-Konstante + + Der READ-DATA-Zeiger (vgl. DATA-Anweisung) wird auf die Zeile + <Zeilennummer> gesetzt. + Wird keine Zeilennummer angegeben, so wird für <Zeilennummer> + 1 eingesetzt. + + Existiert die Programmzeile <Zeilennummer> nicht oder ist in ihr + keine DATA-Anweisung vorhanden, so wird der Zeiger auf die + nächste textuell folgende DATA-Anweisung gesetzt. + Folgt der angegebenen Zeilennummer im Programm keine DATA- + Anweisung mehr, kommt es zu der Fehlermeldung "RESTORE: Keine + DATA-Anweisung in oder nach Zeile <Zeilennummer> gefunden !" + + +Beispiel : 10 READ a, b, c + 20 RESTORE + 30 READ d, e, f + 40 DATA 2, 3, 5 + 50 PRINT a; b; c; d; e; f + Ausgabe: 2 3 5 2 3 5 + +Vergleiche : DATA-, READ-Anweisungen + + + +Anweisung : RETURN + +Zweck : Rücksprung aus einem Unterprogramm + +Syntax : RETURN + +Erklärung : RETURN bewirkt einen Rücksprung aus dem Unterprogramm hinter + die aufrufende GOSUB-Anweisung. + + Es dürfen auch mehrere RETURN-Anweisungen in einem Unterpro + gramm vorkommen, um es an verschiedenen Stellen zu verlassen. + + Wird ein RETURN gefunden, ohne daß ein GOSUB durchlaufen + wurde, so wird mit der Fehlermeldung "RETURN ohne GOSUB" + abgebrochen. + + +Beispiel : 140 GOSUB 10000 'Zeige Uhrzeit + . + . + 370 GOSUB 10000 'Zeige Uhrzeit + 9990 END + 10000 REM Unterprogramm Zeige Uhrzeit + 10010 PRINT "Es ist " + TIME$ + " Uhr" + 10020 RETURN + + +Vergleiche : GOSUB-, ON-Anweisungen + + + +Funktion : RIGHT$ + +Zweck : Erzeugung eines Teiltextes aus einem anderen Text + +Syntax : RIGHT$ (<TEXT-Ausdruck>, <Anzahl Zeichen>) +Erklärung : <Anzahl Zeichen>: INT-Ausdruck + + Die Funktion liefert die letzten <Anzahl Zeichen> Textzeichen des + TEXT-Ausdrucks. + Ist <Anzahl Zeichen> größer gleich der Länge des TEXT- + Ausdrucks, so wird der gesamte Ausdruck geliefert. + + +Beispiel : 10 LET a$ = "hallihallo" + 20 PRINT RIGHT$ (a$, 5) + Ausgabe: hallo + +Vergleiche : LEFT$-, MID$-Funktionen, LSET-, MID$-, RSET-Anweisungen + + + +Funktion : RND + +Zweck : Erzeugung von Zufallszahlen + +Syntax : RND [<num. Ausdruck>] + +Erklärung : Wird kein Argument angegeben, so wird ein Wert größer null für den + Ausdruck angenommen. + + RND (x) liefert + + für x > 0: + eine neue Zufallszahl. Es gilt immer: 0 <= RND < 1. Der Betrag + des Arguments hat keinen Einfluß auf das Ergebnis. + + für x = 0: + die letzte gelieferte Zufallszahl noch einmal. + + für x < 0: + eine neue Zufallszahl. Vorher wird aber RANDOMIZE x (s.d.) ausge + führt. + + Die Zufallszahlen werden als REALs geliefert. + Der Zufallszahlengenerator kann mit der RANDOMIZE-Anweisung + auf bestimmte Startwerte eingestellt werden. + + +Beispiel : 10 FOR i = 1 TO 5 + 20 PRINT INT (RND * 10) + 30 NEXT i + Ausgabe (z.B.): 7 9 9 5 0 + +Vergleiche : RANDOMIZE-Anweisung + + + +Anweisung : RSET + +Zweck : Ersetzen von Zeichen eines Textes von rechts her + +Syntax : RSET <TEXT-Variable> = <TEXT-Ausdruck> + +Erklärung : Das Ergebnis des TEXT-Ausdrucks wird, rechts beginnend, in der + TEXT-Variablen eingesetzt. Es werden höchstens so viele Zeichen + ersetzt, wie bisher schon in der Variablen vorhanden waren, das heißt + die Länge des Textes in der Variablen ändert sich nicht. + Soll ein Text eingesetzt werden, der länger ist als der Text in der + Variablen, so wird die Variable nicht verändert. + + +Beispiel : 210 LET a$ = "ABCDEFG" + 220 RSET a$ = "12345" + 230 PRINT a$, + 240 RSET a$ = "abc" + 250 PRINT a$ + Ausgabe: AB12345 AB12abc + +Vergleiche : LSET-, MID$-Anweisungen, LEFT$-, MID$-, RIGHT$-Funk + tionen + + + +Funktion : SGN + +Zweck : Ermittlung des Vorzeichens einer Zahl + +Syntax : SGN (<num. Ausdruck>) + +Erklärung : SGN (x) liefert + für x > 0: 1 + für x = 0: 0 + für x < 0: -1 . + + +Beispiel : 10 a = -12.74 + 20 PRINT SGN (a); SGN (-a); SGN (0 * a) + Ausgabe: -1 1 0 + +Vergleiche : ABS-Funktion + + + +Funktion : SIN + +Zweck : Berechnung des Sinus eines Radiantwertes + +Syntax : SIN (<Winkel>) + +Erklärung : <Winkel>: REAL-Ausdruck, der den Winkel in Radiant angibt. + Die Funktion liefert den Sinus des Winkels als REAL. + + +Beispiel : 10 PI = 3.141593 + 20 PRINT SIN (PI/4) + Ausgabe: .7071068 + +Vergleiche : COS-, TAN-Funktionen + + + +Funktion : SPACE$ + +Zweck : Erzeugung einer bestimmten Anzahl von Leerzeichen + +Syntax : SPACE$ (<INT-Ausdruck>) + +Erklärung : Die SPACE$-Funktion liefert einen TEXT, der aus so vielen Leerzei + chen (Code 32) besteht, wie der Wert des INT-Ausdrucks angibt. + + +Beispiel : 10 PRINT "123456789" + 20 PRINT "^" + SPACE$ (7) + "^" + + Ausgabe: 123456789 + ^ ^ + + +Vergleiche : STRING$-Funktion + + + +Funktion : SPC + +Diese Funktion entspricht exakt der SPACE$-Funktion und wurde nur aus Kompatibi +litätsgründen implementiert. + + + +Funktion : SQR + +Zweck : Berechnung der Quadratwurzel einer Zahl + +Syntax : SQR (<num. Ausdruck>) + +Erklärung : SQR (x) liefert die Quadratwurzel des durch den numerischen Aus + druck angegebenen Wertes. + Das Ergebnis wird als REAL geliefert. + + +Beispiel : 10 PRINT SQR (100); + 20 PRINT SQR (2); + 30 PRINT SQR (17.453) + Ausgabe: 10 1.414214 4.177679 + + + +Anweisungsbestandteil : STEP + +Siehe FOR-Anweisung + + + +Anweisung : STOP + +Zweck : Beenden der Programmausführung eines BASIC-Programms mit + Meldung + +Syntax : STOP + +Erklärung : STOP beendet die Programmausführung des BASIC-Programms. + Im Gegensatz zu END (s.d.) erzeugt STOP dabei die Meldung "STOP + beendet das Programm in Zeile ...". + + STOP-Anweisungen dürfen im Programm an beliebiger Stelle + stehen, und es darf auch mehr als eine STOP-Anweisung in einem + Programm vorkommen. + Der Compiler übersetzt ein Programm auch nach Erreichen einer + STOP-Anweisung weiter. + + +Beispiel : 3220 IF eingabe$ = "Ende" THEN STOP + + +Vergleiche : END-Anweisung + + + +Funktion : STR$ + +Zweck : Konvertierung einer Zahl in einen Text + +Syntax : STR$ (<num. Ausdruck>) + +Erklärung : Die Funktion liefert die Darstellung des Wertes des numerischen + Ausdrucks als TEXT. + Die Zahlen werden so als Text geliefert, wie sie bei einer PRINT- + Anweisung auf dem Bildschirm erscheinen würden. + + +Beispiel : 10 LET zahl$ = STR$ (1e6) + 20 PRINT zahl$; LEN (zahl$) + Ausgabe: 1000000 7 + +Vergleiche : VAL-Funktion (Komplementärfunktion) + + + +Funktion : STRING$ + +Zweck : Erzeugung eines Textes mit mehreren gleichen Zeichen + +Syntax : STRING$ (<Anzahl>, <Code>|<TEXT-Ausdruck>) + +Erklärung : <Anzahl>: INT-Ausdruck + <Code> : INT-Ausdruck (Wert im Bereich 0 bis 255) + + Die Funktion liefert <Anzahl> mal das Zeichen, + - das den ASCII-Code <Code> hat oder + - das am Anfang vom Ergebnis des TEXT-Ausdrucks steht. + + +Beispiel : 10 LET pfeil$ = STRING$ (10, "=") + ">" + 20 PRINT pfeil$;" ";STRING$ (5, 35) '35 entspr. \# + Ausgabe: ==========> \#\#\#\#\# + +Vergleiche : SPACE$-Funktion + + + +Anweisungsbestandteil : SUB + +Siehe GOSUB-Anweisung + + + +Anweisung : SWAP + +Zweck : Tauschen der Inhalte zweier Variablen + +Syntax : SWAP <Variable1>, <Variable2> + +Erklärung : SWAP tauscht die Inhalte der beiden Variablen. + + Die beiden Variablen müssen vom gleichen Typ sein. + + +Beispiel : 3220 LET a = 10 + 3230 LET b = 20 + 3240 SWAP a, b + 3250 PRINT a; b + Ausgabe: 20 10 + + + +Anweisungsbestandteil : TAB + +Siehe PRINT- und LPRINT-Anweisung + + + +Funktion : TAN + +Zweck : Berechnung des Tangens eines Radiantwertes + +Syntax : TAN (<Winkel>) + +Erklärung : <Winkel>: REAL-Ausdruck, der den Winkel in Radiant angibt. + Die Funktion liefert den Tangens des Winkels als REAL. + + +Beispiel : 10 PI = 3.141593 + 20 PRINT TAN (PI/4) + Ausgabe: 1 + +Vergleiche : COS-, SIN-Funktionen + + + +Anweisungsbestandteil : THEN + +Siehe IF-Anweisung + + + +Funktion : TIMER + +Zweck : Lesen der Systemuhr (CPU-Zeit der Task) + +Syntax : TIMER + +Erklärung : Die bisher von der Task verbrauchte CPU-Zeit (in Sekunden) wird + als REAL geliefert. + + TIMER eignet sich auch zum Starten des Zufallszahlengenerators + (vgl. RANDOMIZE-Anweisung). + + +Beispiel : 2010 LET starttime = TIMER + . + . + 2620 PRINT "Verbrauchte CPU-Zeit:"; + 2630 PRINT TIMER - starttime; "Sekunden" + + +Vergleiche : TIME$-Funktion + + + +Funktion : TIME$ + +Zweck : Abrufen der aktuellen Tageszeit + +Syntax : TIME$ + +Erklärung : Die Tageszeit wird als Text in der Form HH.MM.SS geliefert. + + +Beispiel : 10 PRINT "Es ist jetzt "; TIME$; " Uhr" + Ausgabe (z.B.): Es ist jetzt 10:51:17 Uhr + +Vergleiche : DATE$-, TIMER-Funktionen + + + +Anweisungsbestandteil : TO + +Siehe FOR- und GOTO-Anweisungen + + + +Anweisung : TRON / TROFF + +Zweck : Ein- und Ausschalten der TRACE-Funktion + +Syntax : TRON + TROFF + +Erklärung : Der TRACE-Modus dient der Suche nach logischen Fehlern bei der + Entwicklung von BASIC-Programmen. + + TRON schaltet den TRACE-Modus für die nachfolgend übersetzten + Programmzeilen ein. + + Ist der TRACE-Modus eingeschaltet, so wird für jede gefundene + Zeilennummer die Ausgabe dieser Zeilennummer in eckigen + Klammern mit in den erzeugten Code aufgenommen. Dies hat dann + während des Laufens den Effekt, daß immer bei Abarbeitung der im + TRACE-Modus übersetzten Zeilen die aktuelle Zeilennummer aus + gegeben wird. Es ist so leicht zu verfolgen, in welcher Reihenfolge + die Zeilen des Programms ausgeführt werden. + + TROFF schaltet den TRACE-Modus für die textuell folgenden Pro + grammzeilen wieder aus. + + +Beispiel : 5220 TRON + 5230 REM hier beginnt die kritische + 5240 REM Programmstelle + . + . + . + 5970 TROFF + + + Die Zeilen 5230 bis 5970 werden im TRACE-Modus übersetzt. + + + +Anweisungsbestandteil : USING + +Siehe PRINT-Anweisung + + + +Funktion : USR + +Zweck : Aufruf einer wertliefernden insertierten Prozedur + +Syntax : USR <Prozedurname> + #right#[ (<Parameter> [, <Parameter>] [...] ) ] + +Erklärung : <Prozedurname>: Folge aus Zeichen, die für Prozeduren im + EUMEL-System zugelassen sind (also Buchstaben und - ab der + zweiten Stelle - Zahlen), jedoch keine Leerzeichen. + + <Parameter>: <CONST-Parameter> | <VAR-Parameter> + + <CONST-Parameter>: Ausdruck (genau des von der Prozedur + benötigten Typs) + <VAR-Parameter>: Variable (genau des von der Prozedur benö + tigten Typs) + + Die Prozedur mit dem angegebenen <Prozedurnamen> und den + angegebenen Parametern wird aufgerufen. + Die USR-Funktion liefert nach Ausführung der Prozedur das von der + Prozedur übergebene Ergebnis (Typ INT, REAL oder TEXT). + + Mögliche Fehlerfälle: + - Eine Prozedur mit dem Namen <Prozedurnamen> und den ange + gebenen Parametern gibt es nicht. + - Die Prozedur liefert keinen Wert. + - Die Prozedur liefert einen Typ, der in BASIC unbekannt ist (zum + Beispiel BOOL). + - Die Prozedur benötigt Parametertypen, die in BASIC nicht bekannt + sind (z.B. BOOL, FILE, TASK, QUIET). + - Ein Parameter ist CONST, es wird aber ein VAR-Parameter ver + langt. + + Weitere Informationen finden Sie in Kapitel 4.7. + +Hinweis : 1. Bei den Parametern wird keine Typkonvertierung vorgenommen. + 2. Der Prozedurname muß (entgegen der ELAN-Gewohnheit) ohne + Leerzeichen angegeben werden. + 3. USR ist die einzige Funktion, bei der das Argument (nämlich der + Prozeduraufruf) nicht in Klammern stehen darf. + + +Beispiel : 10 LET euler = USR e + 20 PRINT euler + Ausgabe: 2.718282 + +Vergleiche : CALL-, CHAIN-Anweisungen + + + +Funktion : VAL + +Zweck : Konvertierung eines Texts in eine Zahl + +Syntax : VAL (<TEXT-Ausdruck>) + +Erklärung : Die Funktion liefert den Wert der Zahl, deren Darstellung in dem + übergebenen TEXT-Ausdruck enthalten ist. Führende Leerstellen + werden dabei überlesen. + Sobald ein nicht wandelbares Zeichen festgestellt wird, wird der bis + dahin ermittelte Wert (am Anfang null) geliefert. + + +Beispiel : 10 LET zahl$ = "-1.256E-63" + 20 PRINT VAL (zahl$) + Ausgabe: -1.256E-63 + +Vergleiche : STR$-Funktion (Komplementärfunktion) + + + +Anweisung : WEND + +Zweck : Markierung des Endes einer WHILE-Schleife + +Syntax : WEND + +Erklärung : WEND markiert das Ende einer WHILE-Schleife (vergleiche + WHILE-Anweisung). + +Vergleiche : WHILE-, FOR-Anweisungen + + + +Anweisung : WHILE + +Zweck : Beginn einer abweisenden Schleife + +Syntax : WHILE <Bedingung> + <Schleifenrumpf> + +Erklärung : <Bedingung> : numerischer Ausdruck + <Schleifenrumpf>: Folge von Programmzeilen + + Die WHILE-Anweisung erlaubt die komfortable Programmierung von + abweisenden Schleifen (sogenannten WHILE-WEND-Schleifen) in + BASIC. + Gelangt das Programm während der Ausführung an eine WHILE- + Anweisung, so wird zunächst der Bedingungs-Ausdruck ausge + wertet. Ist die Bedingung nicht erfüllt (falsch, Wert gleich null), so + wird das Programm mit der nächsten Anweisung hinter der korres + pondierenden WEND-Anweisung fortgesetzt. + Ist die Bedingung dagegen erfüllt (wahr, Wert ungleich null), so + werden die Anweisungen des Schleifenrumpfs abgearbeitet. Beim + Erreichen der WEND-Anweisung springt das Programm wieder zur + WHILE-Anweisung zurück, die Bedingung wird erneut überprüft und, + je nach Ergebnis, wird der Schleifenrumpf oder die Anweisung nach + WEND ausgeführt. + + WHILE-WEND-Schleifen dürfen (auch mit FOR-NEXT-Schleifen, + s.d.) geschachtelt werden. Überschneidungen von WHILE-WEND- + Schleifen und FOR-NEXT-Schleifen sind jedoch nicht zulässig. + + +Beispiel : 10 LET weiter$ = "j" + 20 WHILE LEFT$ (weiter$, 1) = "j" + 30 REM Hier beginnt das eigentliche Programm + . + . + 1650 INPUT "Weiter ? (j/n)", weiter$ + 1660 WEND + + + Das eigentliche Programm wird so lange ausgeführt, bis der Benutzer + etwas anderes als "j" an der ersten Stelle von 'weiter$' eingibt. + +Vergleiche : FOR-, IF-Anweisungen + + + +Anweisung : WIDTH + +Zweck : Einstellung der Bildschirmbreite + +Syntax : WIDTH <Zeichen pro Zeile> + +Erklärung : <Zeichen pro Zeile> : INT-Ausdruck + + Mit der WIDTH-Anweisung wird festgelegt, wie viele Zeichen pro + Zeile bei Ausgaben auf den Bildschirm oder in Dateien pro Zeile + ausgegeben werden sollen. + Soll für die Druckdatei eine andere Anzahl von Zeichen pro Zeile + gelten als für den Bildschirm, dann muß vor jeder Sequenz von + LPRINT-Anweisungen die gewünschte Anzahl mit WIDTH einge + stellt werden. + WIDTH gilt auch für Ausgaben in 'sysout'-Dateien. + Insbesondere bei der Ausgabe in Dateien kann ein Wert von mehr als + 80 Zeichen pro Zeile sinnvoll sein. + + +Beispiel : 10 REM es sollen nur 45 Zeichen pro Zeile + 20 REM ausgegeben werden + 30 WIDTH 45 + + +Vergleiche : PRINT-, LPRINT-, WRITE-Anweisungen + + + +Anweisung : WRITE + +Zweck : Ausgabe von Zahlen und Texten auf dem Bildschirm + +Syntax : WRITE [<Ausdruck>] [, <Ausdruck>] [...] + +Erklärung : <Ausdruck>: numerischer Ausdruck oder TEXT-Ausdruck + + Die WRITE-Anweisung erlaubt die Ausgabe von Daten auf dem + Bildschirm. Die angegebenen Ausdrücke werden ausgewertet und + ausgegeben. Dabei werden numerische Werte im gleichen Format + wie bei der PRINT-Anweisung (s.d.) ausgegeben, mit der Einschrän + kung, daß den Zahlen keine Leerstelle folgt. + Die Ergebnisse von Text-Ausdrücken werden von Anführungszei + chen umschlossen ausgegeben. + Alle Einzelausgaben werden durch Kommata voneinander getrennt. + + Nach Ausgabe aller angegebenen Ausdrücke wird der Cursor an den + Anfang der nächsten Zeile positioniert. + + +Beispiel : 10 LET a = 10.7: b = 20 + 20 LET c$ = "Testtext" + 30 WRITE a, b, c$ + Ausgabe: 10.7, 20,"Testtext" + +Vergleiche : PRINT-, LPRINT-, WIDTH-Anweisungen + + + +Operator : XOR + +Siehe Kapitel 4.4. (Operatoren) + diff --git a/lang/basic/1.8.7/doc/basic handbuch.3 b/lang/basic/1.8.7/doc/basic handbuch.3 new file mode 100644 index 0000000..14cb499 --- /dev/null +++ b/lang/basic/1.8.7/doc/basic handbuch.3 @@ -0,0 +1,698 @@ +#page nr ("%",97)# +#head# +EUMEL-BASIC-Compiler 9. Anpassung von Programmen an den EUMEL-BASIC-Compiler % + +#end# + +9. Anpassung von Programmen an den EUMEL-BASIC-Compiler + + +9.1. Unterschiede zwischen BASIC-Inter + pretern und dem EUMEL-BASIC- + Compiler + +Bei der Anpassung von Programmen für BASIC-Interpreter an den EUMEL- +BASIC-Compiler gibt es einige Besonderheiten zu beachten, die auf den unterschied +lichen Arbeitsweisen von Compilern gegenüber Interpretern beruhen. +Bei Interpretern fällt die Übersetzung und Ausführung des Quellprogramms zeitlich +zusammen (genau genommen gibt es ja gar keine Übersetzung, sondern das Quell +programm wird #on("i")#interpretiert#off("i")#). Dies hat zur Folge, daß auch nicht zur Ausführung +bestimmte Anweisungen (z.B. Dimensionierungen, Typfestlegungen etc.) erst während +der Ausführung des Programms erkannt und ausgewertet werden. +Bei Compilern hingegen muß deutlich zwischen der Übersetzungszeit (Compiletime) +und der Laufzeit (Runtime) eines Programms unterschieden werden. +Der wesentliche Unterschied zwischen Compilern und Interpretern liegt nun in der +Reihenfolge der Kenntnisnahme von den Anweisungen. Während der Interpreter von +den Anweisungen in der Reihenfolge ihres Auftretens entlang des Programmablaufs +Kenntnis nimmt, werden die Anweisungen vom Compiler in der Reihenfolge ihres +textuellen Auftretens zur Kenntnis genommen. +Da es sich bei dem EUMEL-BASIC-Compiler um einen One-Pass-Compiler +handelt, ist es zwingend notwendig, daß +- DIM-Anweisungen vor dem ersten Zugriff auf das zu dimensionierende Feld + stehen. +- OPTION BASE-Anweisungen vor den betreffenden Dimensionierungen stehen. +- DEF FN-Anweisungen vor dem ersten Aufruf der zu definierenden Funktion ste + hen. +- DEFINT- beziehungsweise DEFSTR-Anweisungen vor der ersten Verwendung der + betreffenden Variablen erscheinen. + +Einige Interpreter lassen sogar den Abschluß von FOR-NEXT- und WHILE- +WEND-Schleifen an mehreren Stellen im Programm zu (z.B. mehrere NEXT- +Anweisungen zu einer FOR-Anweisung). Auch solche "Kunstgriffe" gestattet der +EUMEL-BASIC-Compiler (aus den oben geschilderten Gründen) nicht. + + + + +9.2. Abweichungen von ISO 6373-1984 + (Minimal-BASIC) + + + +Der EUMEL-BASIC-Compiler weicht in folgenden Punkten von der ISO-Norm +6373-1984 für Minimal-BASIC ab: +- Treten bei der Auswertung von numerischen Ausdrücken Überläufe auf, so wird + nicht, wie im Standard vorgesehen, eine Warnung ausgegeben und mit bestimmten + Höchstwerten weitergerechnet, sondern die Ausführung des BASIC-Programms + wird mit einer entsprechenden Fehlermeldung abgebrochen. +- Nimmt die Sprungziel-Nummer bei der ON-Anweisung einen fehlerhaften Wert an + (Nummer < 1 oder Nummer > Anzahl Sprungziele), dann wird nicht, wie im + Standard empfohlen, mit einer Fehlermeldung abgebrochen, sondern es wird (wie + auch in Microsoft-BASIC üblich) das Programm mit der der ON-Anweisung fol + genden Anweisung fortgesetzt. +- Bei der DATA-Anweisung müssen nicht unbedingt Zeichenfolgen angegeben + werden. Werden sie weggelassen, dann wird bei Ausführung der READ- + Anweisung null beziehungsweise Leertext geliefert (vergleiche Kapitel 8, DATA- + Anweisung). +- Bei den Eingaben für eine INPUT-Anweisung können ebenfalls die Daten wegge + lassen werden. Auch hier wird null beziehungsweise Leertext geliefert (vergleiche + Kapitel 8, INPUT-Anweisung) + + +Die Erweiterungen gegenüber ISO 6373 sollen hier nicht im einzelnen aufgeführt +werden. Bitte vergleichen Sie in Zweifelsfällen die Normungsschrift mit dieser Doku +mentation! + + + + +9.3. Anpassung von Microsoft-BASIC Pro + grammen an den EUMEL-BASIC- + Compiler + + + +Bei der Entwicklung des EUMEL-BASIC-Compilers wurde zwar auf Übereinstim +mung mit Microsoft-BASIC Wert gelegt, von einer echten Kompatibilität kann aber +aufgrund einer ganzen Reihe fehlender Anweisungen und Funktionen nicht gespro +chen werden. +Gegenüber Microsoft-BASIC fehlen vor allem: +- alle "Direkt-Kommandos" (RUN, LIST, LOAD, SAVE, MERGE usw.). Die Aufgaben + dieser Anweisungen werden von den Prozeduren des EUMEL-Systems über + nommen. +- im weiteren Sinne "hardware-nahe" oder an Maschinensprache orientierte Anwei + sungen und Funktionen (CALL, PEEK, POKE, USR, WAIT usw.) +- die ERROR-Handling Anweisungen (ON ERROR, RESUME) +- die Dateiverarbeitungs-Anweisungen und -Funktion (INPUT\#, PRINT\# u.a.; die + INPUT- und PRINT-Anweisungen wurden aber auf Zusammenarbeit mit 'sysin' + und 'sysout' abgestimmt.) +- die Single-Precision-Variablen (Single- und Double-Precision-Variablen wer + den beide auf den Datentyp REAL abgebildet.) +- die hexadezimalen und oktalen Konstanten + +Anweisungen und Funktionen, die sich abweichend vom Microsoft-Standard verhal +ten, sind vor allem: +- CALL, CHAIN, USR +- ERROR, ERR, ERL +- LSET, RSET + +Wichtige Erweiterungen gegenüber Microsoft-BASIC sind: +- Möglichkeit des Aufrufs von ELAN-Prozeduren +- Maximale Anzahl von Zeichen pro Zeile: 32000 +- Maximale Anzahl von Zeichen pro TEXT-Objekt: 32000 +- OPTION BASE wirkt auf einzelne Felder (und nicht unbedingt auf ein ganzes + Programm) + +#on ("b")# +Hinweis zur Verwendung von MS-BASIC-Programmen im EUMEL-System#off ("b")# +Sollen Microsoft-BASIC-Programme in das EUMEL-Systemm übernommen wer +den, so ist dabei so vorzugehen: +1. Speichern Sie das Programm von MS-BASIC aus mit der ASCII-SAVE-Option + ab. + Beispiel: SAVE "PROGRAMM.BAS",A +2. Lesen Sie das Programm mittels "DOSDAT" (Programm zum Lesen von MS- + DOS-Dateien) im "file ascii"-Modus ein: + + reserve ("file ascii", /"DOS"); fetch ("PROGRAMM.BAS", /"DOS") + +Danach steht ihnen das BASIC-Program in der EUMEL-Textdatei +"PROGRAMM.BAS" zur Verfügung. + +#page# +#head# +EUMEL-BASIC-Compiler Anhang A: Reservierte Wörter % + +#end# + +Anhang A: #ib(4)#Reservierte Wörter#ie(4)# +Dieser Anhang enthält eine Übersicht über alle vom EUMEL-BASIC-Compiler +erkannten reservierten Wörter. + +ABS Funktion +AND Operator +AS Anweisungsbestandteil +ASC Funktion +ATN Funktion +BASE Anweisungsbestandteil +CALL Anweisung +CDBL Funktion +CHAIN Anweisung +CHR$ Funktion +CINT Funktion +CLEAR nicht implementiert +CLOSE nicht implementiert +CLS Anweisung +COMMON nicht implementiert +FIELD nicht implementiert +COS Funktion +CSRLIN Funktion +CVD Funktion +CVI Funktion +DATA Anweisung +DATE$ Funktion +DEF Anweisung +DEFDBL Anweisung +DEFINT Anweisung +DEFSNG Anweisung +DEFSTR Anweisung +DIM Anweisung +ELSE Anweisungsbestandteil +END Anweisung +EOF Anweisungsbestandteil +EQV Operator +ERL Funktion +ERM$ Funktion +ERR Funktion +ERROR Anweisung +EXP Funktion +FIX Funktion +FOR Anweisung +FRE Funktion +GET nicht implementiert +GO Anweisungsbestandteil +GOSUB Anweisung +GOTO Anweisung +HEX$ Funktion +IF Anweisung +IMP Operator +INKEY$ Funktion +INPUT Anweisung +INPUT$ Funktion +INSTR Funktion +INT Funktion +KILL Anweisung +LEFT$ Funktion +LEN Funktion +LET Anweisung +LINE Anweisungsbestandteil +LOC nicht implementiert +LOG Funktion +LPOS Funktion +LPRINT Anweisung +LSET Anweisung +MID$ Anweisung/Funktion +MKD$ Funktion +MKI$ Funktion +MOD Operator +NAME Anweisung +NEXT Anweisung +NOT Operator +OCT$ Funktion +ON Anweisung +OPEN nicht implementiert +OPTION Anweisung +OR Operator +OUT nicht implementiert +POS Funktion +PRINT Anweisung +PUT nicht implementiert +RANDOMIZE Anweisung +READ Anweisung +REM Anweisung +RESTORE Anweisung +RESUME nicht implementiert +RETURN Anweisung +RIGHT$ Funktion +RND Funktion +RSET Anweisung +SGN Funktion +SIN Funktion +SPACE$ Funktion +SPC Funktion +SQR Funktion +STEP Anweisungsbestandteil +STOP Anweisung +STR$ Funktion +STRING$ Funktion +SUB Anweisungsbestandteil +SWAP Anweisung +TAB Anweisungsbestandteil +TAN Funktion +THEN Anweisungsbestandteil +TIME$ Funktion +TIMER Funktion +TO Anweisungsbestandteil +TROFF Anweisung +TRON Anweisung +USING Anweisungsbestandteil +USR Funktion +VAL Funktion +WAIT nicht implementiert +WEND Anweisung +WHILE Anweisung +WIDTH Anweisung +WRITE Anweisung +XOR Operator +#page# +#head# +EUMEL-BASIC-Compiler Anhang B: Vom Scanner erkannte Symboltypen % + +#end# + +Anhang B: Vom #ib(3)#Scanner#ie(3)# erkannte #ib(3)#Symbol +typen#ie(3)# + + Der Scanner (ein Paket des EUMEL-BASIC-Systems) hat die Aufgabe, den Pro +grammtext Zeichen für Zeichen durchzugehen und auszulesen ('scannen'). Dabei +werden die Zeichen immer zu logischen Gruppen, sogenannten #on("i")#Symbolen#off("i")# zusammen +gefaßt. Diese Symbole werden dann dem eigentlichen Compilerprogramm geliefert. +Der Scanner entscheidet nach recht komplizierten Regeln, welche Zeichen aus der +Quelldatei zu einem Symbol zusammengefaßt werden. Dennoch soll in diesem An +hang der Begriff des Symbols etwas näher erklärt werden, da der Anwender (vor allem +bei den Fehlermeldungen) mit Symboltypen konfrontiert wird. + + + +Reservierte Wörter +#on ("b")# +Anfangszeichen:#off ("b")# Buchstaben +#on ("b")# +Folgezeichen:#off ("b")# Buchstaben +#on ("b")# +Beispiele:#off ("b")# PRINT, VAL, TAB, SUB, TO +#on ("b")# +Vergleiche:#off ("b")# Anhang A + + + +Operatoren ++ - * / \ ^ MOD +NOT AND OR XOR EQV IMP +< > = <= >= <> + +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.4. + + + +numerische Konstanten +#on ("b")# +Anfangszeichen:#off ("b")# Ziffern 0 bis 9, Dezimalpunkt '.' +#on ("b")# +Folgezeichen:#off ("b")# zusätzlich: 'd', 'D', 'e' oder 'E', am Schluß auch '%', '!' oder '\#' +#on ("b")# +Beispiele:#off ("b")# 1.0, 1.256d123, 12! +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.2. + + + +TEXT-Konstanten +#on ("b")# +Anfangszeichen:#off ("b")# Anführungszeichen +#on ("b")# +Folgezeichen:#off ("b")# Alle Zeichen, sogar Doppelpunkte, Apostrophe und Steuerzei + chen. Anführungszeichen dürfen #on("i")#innerhalb#off("i")# von + TEXT-Konstanten nicht vorkommen. Eine + TEXT-Konstante #on("i")#muß#off("i")# aber mit einem Anfüh + rungszeichen enden. +#on ("b")# +Beispiele:#off ("b")# "tadellos", "!?': alles mögliche" +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.2. + + + +Variablen +#on ("b")# +Anfangszeichen:#off ("b")# Buchstaben +#on ("b")# +Folgezeichen:#off ("b")# zusätzlich: Punkt '.', Ziffern 0 bis 9, Zeichen '$', '%', '!' und '\#' +#on ("b")# +Beispiele:#off ("b")# zeiger, A$, Zahl!, n%, var\#4.3% +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.3. + + + +Felder/Feldelemente +wie Variablen, jedoch gefolgt von '(', den Indexangaben und ')' +#on ("b")# +Beispiele:#off ("b")# zeiger (3), A$ (pointer), Zahl! (7), n% (a, b, c + d) +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.3. + + + +Benutzer-definierte Funktionen +#on ("b")# +Anfangszeichen:#off ("b")# FN +#on ("b")# +Folgezeichen:#off ("b")# Buchstaben, Punkt '.', Ziffern 0 bis 9, + Zeichen '$', '%', '!' und '\#' +#on ("b")# +Beispiele:#off ("b")# FNfunct, FNgauss%, FNf!4.5.6d\# +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.5. + + + +EOS (End of Statement, Anweisungsende) +Doppelpunkt ':' + +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.1. + + + +EOL (End of Line, Zeilenende) +Apostrophzeichen ' oder Ende der Dateizeile +EOL bedeutet gleichzeitig auch EOS + +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.1. + + + +EOF (End of File, Dateiende) +Ende der Quelldatei +EOF bedeutet gleichzeitig auch EOL (und somit auch EOS) + +#on ("b")# +Vergleiche:#off ("b")# Kapitel 4.1. + + + +Trennzeichen +Alle bisher nicht genannten Zeichen werden vom Scanner als Trennzeichen behan +delt. In BASIC benötigte Trennzeichen sind das Komma (','), das Semikolon (';') sowie +die beiden runden Klammern '(' und ')'. +Zeichen mit Codes kleiner als 32 (Steuerzeichen) werden vom Scanner überlesen. +#page# +#head# +EUMEL-BASIC-Compiler Anhang C: Übersicht über die Fehlermeldungen % + +#end# + +Anhang C: Übersicht über die Fehlermeldungen + + +Übersicht über die verwendeten Fehlermeldungen zur +Übersetzungszeit +Diese Übersicht enthält alle zur Übersetzungszeit möglichen Fehler, mit Ausnahme +der internen Fehler. +Die Erläuterungen geben die üblichen Ursachen für die Fehlermeldung an. Es wird +empfohlen, sich im Falle eines Fehlers außerdem in Kapitel 8 über die genaue Syntax +der betreffenden Anweisung beziehungsweise Funktion zu informieren. + + +#on ("b")#AS ohne NAME#off ("b")# +AS darf nur in NAME-Anweisungen vorkommen. + +#on ("b")#Accessrecht VAR erwartet, CONST gefunden#off ("b")# +Beim Aufruf einer ELAN-Prozedur (CALL, CHAIN oder USR) wurde ein VAR-Para +meter verlangt. Angegeben wurde aber ein CONST-Parameter (zum Beispiel ein +Ausdruck). + +#on ("b")#Ausdruck erwartet#off ("b")# +Es wurde ein numerischer oder TEXT-Ausdruck erwartet. Diese Fehlermeldung +erscheint zum Beispiel, wenn nach einem Operator kein Ausdruck mehr gefunden +wird. + +#on ("b")#BASE ohne OPTION#off ("b")# +BASE darf nur in OPTION BASE-Anweisungen vorkommen. + +#on ("b")#Bei SWAP nur gleiche Variablentypen erlaubt#off ("b")# +Mit SWAP können nur Variablen von genau dem gleichen Typ bearbeitet werden. + +#on ("b")#Das Feld ist bereits dimensioniert#off ("b")# +Diese Fehlermeldung erscheint bei DIM-Anweisungen, wenn das Feld vorher schon +explizit oder automatisch dimensioniert wurde. + +#on ("b")#ELSE ohne IF#off ("b")# +ELSE darf nur in IF-Anweisungen vorkommen. ELSE muß in der gleichen Zeile +stehen wie die zugehörige IF-Anweisung. + +#on ("b")#Falsche Felddimension: +Dimensioniert in ... Dimensionen, gefundene Anzahl Indizes: ...#off ("b")# +Beim Zugriff auf ein Feldelement wurden zu viele oder zu wenig Indizes angegeben. + +#on ("b")#FOR ohne NEXT#off ("b")# +Diese Fehlermeldung erscheint, wenn am Programmende für eine FOR-Anweisung +kein korrespondierendes NEXT gefunden wurde. + +#on ("b")#Falsche Reihenfolge der Zeilennummern#off ("b")# +Die Zeilennummern wurden nicht in aufsteigender Reihenfolge angegeben. + +#on ("b")#Falscher Typ#off ("b")# +Es wurde ein anderer Datentyp erwartet als angegeben, und es konnte keine automa +tische Konvertierung vorgenommen werden. + +#on ("b")#Falscher Typ der Operanden#off ("b")# +Bei einem dyadischen Operator wurden Operanden angegeben, für deren Typen +dieser Operator nicht definiert ist (vergleiche Kapitel 4.4.). + +#on ("b")#Falscher Typ des Operanden#off ("b")# +Bei einem monadischen Operator wurde ein Operand angegeben, für dessen Typ +dieser Operator nicht definiert ist (vergleiche Kapitel 4.4.). + +#on ("b")#Fehlerhafte Bereichsangabe#off ("b")# +Diese Fehlermeldung kann bei den Anweisungen DEFDBL, DEFINT, DEFSNG und +DEFSTR auftreten, wenn bei einer Bereichsangabe der Buchstabe vor dem Binde +strich im Alphabet nach dem Buchstaben hinter dem Bindestrich steht. + +#on ("b")#Fehlerhafte Dimensionierung: Die Obergrenze muß >= 1 sein#off ("b")# +Es wurde versucht, ein Feld mit dem größten Index null in einer Dimension zu +dimensionieren, obwohl die Index-Untergrenze mit OPTION BASE auf eins einge +stellt war. + +#on ("b")#Fehlerhafte Laufvariable#off ("b")# +Nach einer NEXT-Anweisung wurde eine Laufvariable gefunden, die nicht zur letzten +anhängigen FOR-Anweisung gehört. Der Fehler tritt auf, wenn Schleifen geschachtelt +wurden. + +#on ("b")#Fehlerhafte Zeilennummer#off ("b")# +Die Zeilennumer entspricht nicht der Syntax für Zeilennumern. + +#on ("b")#Fehlerhafter Funktionsaufruf#off ("b")# +- Die Prozedur liefert keinen Wert + Es wurde versucht, eine Prozedur mit USR aufzurufen, die keinen Wert liefert. +- Der Typ des Resultats ist nicht erlaubt, gefunden: ... + Es wurde versucht, eine Prozedur mit USR aufzurufen, die ein Objekt liefert, + dessen Datentyp in BASIC nicht bekannt ist. +- Kein Argument erwartet + Es wurde versucht, eine benutzer-definierte Funktion, die ohne Parameter definiert + wurde, mit Argument(en) aufzurufen. +- ... Argument(e) erwartet + Die Anzahl der angegebenen Argumente ist kleiner als die Anzahl der bei der + Funktionsdefinition angegebenen Parameter. +- Nur ... Argument(e) erwartet + Die Anzahl der angegebenen Argumente ist größer als die Anzahl der bei der Funk + tionsdefinition angegebenen Parameter. +- Kein Resultat erlaubt (gefunden: ...) + Bei CALL oder CHAIN wurde versucht, eine wertliefernde Prozedur aufzurufen. + +#on ("b")#Funktionsaufruf ohne Zusammenhang#off ("b")# +Es wurde ein Funktionsaufruf angegeben, wo eine Anweisung erwartet wurde. + +#on ("b")#GO ohne TO oder SUB#off ("b")# +Das reservierte Wort GO kann nur in GO SUB oder GO TO auftreten. + +#on ("b")#Interner Fehler#off ("b")# +Bei der Übersetzung wurde innerhalb des Compilerprogramms ein interner Fehler +ausgelöst. (vergleiche Kapitel 7.1.) + +#on ("b")#Nach OPTION BASE ist nur 0 oder 1 erlaubt#off ("b")# +Es wurde versucht, eine Zahl > 1 nach OPTION BASE anzugeben. + +#on ("b")#NEXT ohne FOR#off ("b")# +Es wurde eine NEXT-Anweisung gefunden, die keiner FOR-Anweisung zuzuordnen +ist, da keine "offenen" FOR-Schleifen mehr anhängig sind. + +#on ("b")#Nicht implementiert#off ("b")# +Einige reservierte Wörter werden vom BASIC-Compiler erkannt, obwohl die zugehö +rigen Anweisungen oder Funktionen nicht implementiert sind (vgl. Anhang A). + +#on ("b")#Parametervariable kommt mehrmals vor#off ("b")# +Bei der Definition einer "user function" kommt ein Parameter in der Parameterliste +mehr als einmal vor. + +#on ("b")#Rekursive Funktionsdefinition#off ("b")# +Es wurde versucht, in der Definition einer "user function" die zu definierende Funk +tion aufzurufen. + +#on ("b")#STEP ohne FOR#off ("b")# +STEP darf nur in FOR-Anweisungen vorkommen. + +#on ("b")#SUB ohne GO#off ("b")# +SUB darf nur in GOSUB vorkommen. + +#on ("b")#Syntaxfehler: <nähere Fehlerangabe>#off ("b")# +Wenn dieser Fehler erscheint, wurde vom Compiler eine Angabe gefunden, die nach +den Syntaxregeln dort nicht erwartet wurde oder fehlerhaft ist. + +#on ("b")#TAB ohne (L)PRINT#off ("b")# +TAB darf nur in PRINT- und LPRINT-Anweisungen vorkommen. + +#on ("b")#THEN ohne IF#off ("b")# +THEN darf nur in IF-Anweisungen vorkommen. THEN muß in der gleichen Zeile +stehen wie die zugehörige IF-Anweisung. + +#on ("b")#TO ohne Zusammenhang#off ("b")# +TO darf nur in FOR-Anweisungen oder in GO TO vorkommen. + +#on ("b")#Text zu lang#off ("b")# +Dieser Fehler erscheint, wenn ein Anführungszeichen fehlt beziehungsweise ein +Anführungszeichen zu viel gefunden wird. + +#on ("b")#Unbekannte Funktion, Argument(e) angegeben: ...#off ("b")# +Es wurde versucht, eine Funktion mit einem Argument aufzurufen, für dessen Typ die +Funktion nicht definiert ist. + +#on ("b")#Unbekannte Prozedur, Parameter angegeben: ...#off ("b")# +Die angegebene Prozedur konnte mit den angegebenen Parametertypen nicht gefun +den werden. + +#on ("b")#Undefinierte 'user function'#off ("b")# +Es wurde versucht, eine benutzer-definierte Funktion aufzurufen, die (noch) nicht +definiert wurde. + +#on ("b")#USING ohne (L)PRINT#off ("b")# +USING darf nur in PRINT- und LPRINT-Anweisungen vorkommen. + +#on ("b")#WEND ohne WHILE#off ("b")# +Es wurde eine WEND-Anweisung gefunden, die keiner WHILE-Anweisung zuzuord +nen ist, da keine "offenen" WHILE-Schleifen mehr anhängig sind. + +#on ("b")#WHILE ohne WEND#off ("b")# +Diese Fehlermeldung erscheint, wenn am Programmende für eine WHILE-Anweisung +kein korrespondierendes WEND gefunden wurde. + +#on ("b")#Zeile mit dieser Nummer existiert nicht#off ("b")# +Es wurde versucht, mit GOTO oder GOSUB zu einer Zeilennumer zu verzweigen, die +im Programm nicht angegeben wurde. + + + + +Übersicht über die innerhalb des BASIC-Systems +ausgelösten Laufzeitfehler +Die meisten Laufzeitfehler werden auch bei BASIC-Programmen im EUMEL-System +erzeugt (vergleiche Kapitel 7.2.). Einige werden aber innerhalb des BASIC-Systems +erzeugt. Die nachfolgende Übersicht enthält die innerhalb des BASIC-Systems aus +gelösten Fehler mit Angabe des gelieferten Fehlercodes und der Fehlermeldung. + +#on ("b")#Fehlercode:#off ("b")# 1003 +#on ("b")#Fehlermeldung:#off ("b")# RETURN ohne GOSUB +Eine RETURN-Anweisung wurde gefunden, obwohl keine GOSUB-Anweisung mehr +anhängig war. + + +#on ("b")#Fehlercode:#off ("b")# 1004 +#on ("b")#Fehlermeldung:#off ("b")# RESTORE: Keine DATA-Anweisung in oder nach +#right#Zeile ... gefunden +Eine RESTORE-Anweisung konnte nicht ausgeführt werden, weil in oder nach der in +der Anweisung angegebenen Zeilennummer keine DATA-Anweisung mehr steht. + + +#on ("b")#Fehlercode:#off ("b")# 1005 +#on ("b")#Fehlermeldung:#off ("b")# bei ^: negative Basis, gebrochener Exponent: ... +Es wurde versucht, eine negative Zahl mit einer gebrochenen Zahl zu potenzieren. + + +#on ("b")#Fehlercode:#off ("b")# 1005 +#on ("b")#Fehlermeldung:#off ("b")# USING: kein Format gefunden +Bei einer PRINT USING-Anweisung wurde kein Format für die Ausgabe angegeben +oder die Formatzeichenkette enthält keine Formatzeichen. + + +#on ("b")#Fehlercode:#off ("b")# 1005 +#on ("b")#Fehlermeldung:#off ("b")# USING-Format fehlerhaft: ... +Bei einer PRINT USING-Anweisung wurde ein fehlerhaftes Format angegeben. + + +#on ("b")#Fehlercode:#off ("b")# 1004 +#on ("b")#Fehlermeldung:#off ("b")# Keine Daten mehr für READ +Es stehen keine Daten mehr für die READ-Anweisung zur Verfügung; der READ- +DATA-Zeiger zeigt hinter das Ende der letzten DATA-Anweisung. + + +#on ("b")#Fehlercode:#off ("b")# 1005 +#on ("b")#Fehlermeldung:#off ("b")# WIDTH: negative Angabe: ... +Nach WIDTH wurde eine negative Zahl gefunden. + + +#on ("b")#Fehlercode:#off ("b")# 1013 +#on ("b")#Fehlermeldung:#off ("b")# READ: Falscher Datentyp, ... ist kein INT +Einer INT-Variablen konnte kein Wert zugewiesen werden, da das aktuelle Objekt +aus der DATA-Liste keine gültige Darstellung eines INT-Wertes war oder ein +"quoted string" gefunden wurde. + + +#on ("b")#Fehlercode:#off ("b")# 1013 +#on ("b")#Fehlermeldung:#off ("b")# READ: Falscher Datentyp, ... ist kein REAL +Einer REAL-Variablen konnte kein Wert zugewiesen werden, da das aktuelle Objekt +aus der DATA-Liste keine gültige Darstellung eines REAL-Wertes war oder ein +"quoted string" gefunden wurde. + + +#on ("b")#Fehlercode:#off ("b")# 1051 (interner Fehler) +#on ("b")#Fehlermeldung:#off ("b")# variierend +Bei der Ausführung des Programms trat in einer Prozedur des BASIC-Systems ein +interner Fehler auf. (Vergleiche Kapitel 7.) + + +#on ("b")#Fehlercode:#off ("b")# 1080 +#on ("b")#Fehlermeldung:#off ("b")# INPUT-Fehler ( Fehlerart ) : > Eingabezeile < +Bei einer INPUT-Anweisung, die auf eine mit 'sysin' eingestellte Datei wirken sollte, +kam es zu einem Fehler der angegebenen Fehlerart. Nach dem Doppelpunkt wird die +Eingabezeile aus der Eingabedatei ausgegeben. +#page# +#head# +EUMEL-BASIC-Compiler Anhang D: ELAN-Prozeduren des Compilers % + +#end# + +Anhang D: ELAN-Prozeduren des Compilers + + #on ("b")#PROC #ib(3)#basic#ie(3)# (TEXT CONST dateiname)#off ("b")# + Das in der Datei 'dateiname' enthaltene BASIC-Programm wird dem BASIC- + Compiler zur Übersetzung übergeben. Werden keine Fehler gefunden, so wird das + Programm direkt nach der Übersetzung ausgeführt. + Beispiel: + + basic ("Mein liebstes BASIC-Programm")#off ("b")# + + + #on ("b")#PROC basic (TEXT CONST dateiname, prozedurname)#off ("b")# + Das in der Datei 'dateiname' enthaltene BASIC-Programm wird dem BASIC- + Compiler zur Übersetzung übergeben. Werden keine Fehler gefunden, dann wird + das Programm unter dem Namen 'prozedurname' dauerhaft eingetragen (inser + tiert). + Das Programm wird nicht ausgeführt. Beachten Sie, daß der Prozedurname den + Vorschriften für ELAN-Prozedurnamen entsprechen muß und außerdem #on ("b")#keine + Leerzeichen#off ("b")# enthalten darf. (Zur Namenswahl siehe auch Kapitel 3.) + Beispiel: + + basic ("Mein liebstes BASIC-Programm", "liebstesprogramm")#off ("b")# + + + + #on ("b")#PROC #ib(3)#basic list#ie(3)# (BOOL CONST status)#off ("b")# + Mit der Prozedur 'basic list' kann eingestellt werden, ob die gerade vom Compiler + übersetzten Programmzeilen angezeigt werden sollen oder nicht (vergleiche Kapitel + 3.). + + basic list (TRUE)#off ("b")#: Die übersetzten Zeile werden angezeigt + basic list (FALSE)#off ("b")#: Die übersetzten Zeile werden nicht angezeigt + + + #on ("b")#PROC #ib(3)#basic page#ie(3)# (BOOL CONST status)#off ("b")# + Mit der Prozedur 'basic page' kann eingestellt werden, wie die Ausgaben von + BASIC-Programmen behandelt werden, wenn der Bildschirm voll ist (vergleiche + Kapitel 5, Steuerung der Bildschirmausgaben). + + basic page (TRUE): Beim Erreichen des Bildschirmendes wird auf einen + Tastendruck gewartet (vgl. Kap. 5.) + basic page (FALSE): Beim Erreichen des Bildschirmendes wird 'gescrollt'. + diff --git a/lang/basic/1.8.7/doc/basic handbuch.index b/lang/basic/1.8.7/doc/basic handbuch.index new file mode 100644 index 0000000..4ac7e16 --- /dev/null +++ b/lang/basic/1.8.7/doc/basic handbuch.index @@ -0,0 +1,232 @@ +#page nr ("%",115)# +#head# +EUMEL-BASIC-Compiler Stichwortverzeichnis % + +#end# + +Stichwortverzeichnis + +>= 15 +\ 14 +- 14 ++ 14 ++ 15 +<= 15 +* 14 +/ 14 += 15 +> 15 +< 15 +<> 15 +^ 14 +ABS 31 +AND 16 +Anführungszeichen 10 +Argument 21 +Arithmetische Operatoren 14 +Arrays 13 +ASC 32 +ATN 32 +Äquivalenz-Verknüpfung 17 +Aufruf benutzer-definierter Funktionen 21 +Aufruf und Steuerung des BASIC-Compilers 5 +basic 5, 113 +BASIC-Compiler ERROR 28 +basic list 6, 113 +basic page 25, 114 +benutzer-definierte Funktionen 19, 104 +Bildschirmausgaben 25 +CALL 23, 33 +CDBL 35 +CHAIN 23, 35 +CHR$ 35 +CINT 36 +CLS 36 +Codebereichs pro Task 27 +Compiler Error 304 26 +Compiler Error 307 26 +Compiler Error 308 26 +COS 37 +CSRLIN 37 +CVD, CVI 38 +DATA 38 +DATE$ 40 +Datentypen 10 +Datentyp INT 10 +Datentyp REAL 10 +Datentyp TEXT 10 +Debugging 6 +DEFDBL, DEFINT, DEFSNG, DEFSTR 40 +DEF FN 19, 28, 42 +Definition benutzer-definierter Funktionen 19 +DEFINT 12 +DEFSTR 12 +DIM 13, 43 +Dimensionen 13 +Doppelpunkt 8 +ELSE 54 +END 45 +EOF 56 +EOF (End of File, Dateiende) 7, 105 +EOL (End of Line, Zeilenende) 8, 105 +EOS (End of Statement, Anweisungsende) 8, 105 +EQV 17 +ERL 46 +ERM$ 47 +ERR 47 +ERROR 48 +EUMEL-Coder 26 +EUMEL-Textdatei 7 +Exklusiv-ODER-Verknüpfung 17 +EXP 49 +Exponent 10 +Fehlerbehandlung 28 +Fehlercodes 30 +Fehlerzeile 30 +Fehler zur Laufzeit 30, 111 +Fehler zur Übersetzungszeit 28, 106 +Felder (Arrays) 13 +Felder/Feldelemente 104 +Feldnamen 13 +FIX 49 +FOR 50 +FRE 51 +Funktionen 19 +Funktionsaufrufe 19 +Ganzzahlen 10 +Generatorprogramm 4 +Gleitkommazahlen 10 +GOSUB 52 +GOTO 53 +Grenzen des Compilers 26 +Groß-/Kleinschreibung 9 +Hauptdurchlauf 28 +HEX$ 54 +Hochkomma 8 +IF 54 +IMP 17 +Implikations-Verknüpfung 17 +Indizes 13 +INKEY$ 56 +INPUT$ 58 +INPUT 56 +Insertieren von BASIC-Programmen 5 +Installation des BASIC-Compilers 4 +INSTR 59 +INT 59 +Interne Compilerfehler 28 +INTs 10 +INT-Überlauf 15 +KILL 60 +Konstanten 10 +Konvertierung 15, 22 +Kriterien für den Typ einer Variablen 12 +Labels 26 +Leerzeichen 9 +LEFT$ 60 +LEN 61 +LET 61 +LINE INPUT 62 +LOG 63 +Logische Operatoren 16 +LPOS 63 +LPRINT 64 +LSET 65 +Mantisse 11 +MID$ 65, 66 +MKD$, MKI$ 67 +MOD 14 +Modulgrenze 26 +NAME 68 +Namenstabelle 27 +Negation 16 +negative Zahlenwerte 11 +NEXT 50, 68 +NOT 16 +Notation 3 +Notebook 28 +numerische Konstanten 103 +OCT$ 69 +ODER-Verknüpfung 17 +ON 69 +Operatoren 103 +Operatoren, arithmetische 14 +Operatoren, logische 16 +Operatoren, Text- 15 +Operatoren, Vergleichs- 15 +Operator, Zuweisungs- 18 +OPTION BASE 13, 71 +OR 17 +Parameter 19 +POS 72 +PRINT 72 +Prioritäten der Operanden 18 +Programmdatei 7 +Programmsegmente 24 +Programmzeile 7 +RANDOMIZE 75 +READ 75 +REM 77 +Reservierte Wörter 9, 12, 100, 103 +RESTORE 77 +RETURN 78 +RIGHT$ 79 +RND 80 +RSET 81 +Scanner 9, 103 +Schlüsselwörter 9 +Scrolling 25 +SGN 81 +SIN 82 +SPACE$ 82 +SPC 83 +SQR 83 +Standard-Funktionen 19 +STEP 50 +Steuerung der Bildschirmausgaben 25 +Steuerung des BASIC-Compilers 5 +STOP 84 +STR$ 84 +STRING$ 85 +SUB 52 +SWAP 86 +Symbol 9 +Symboltypen 103 +Syntax 7 +sysout 6 +TAB 64, 72 +TAN 86 +Texte 10 +TEXT-Konstanten 104 +Text-Operator + 15 +THEN 54 +TIME$ 88 +TIMER 87 +TO 50, 53 +Trennzeichen 105 +TRON / TROFF 88 +Typanpassung 22 +UND-Verknüpfung 16 +USING 64, 72 +USR 23, 90 +Übersetzen von BASIC-Programmen 5 +Übersichtlichkeit von BASIC-Programmen 7 +VAL 91 +Variablen 12, 104 +Variablennamen 9, 12 +VAR-Parameter 23 +Vergleichsoperatoren 15 +Vordurchlauf 28 +Vorzeichen 11 +Wahrheitswerte 16 +Weitere Schreibregeln 9 +WEND 92 +wertliefernden Prozeduren 23 +WHILE 92 +WIDTH 93 +WRITE 94 +XOR 17 +Zahlen 10 +Zeilennummer 7 +Zuweisungsoperator 18 + diff --git a/lang/basic/1.8.7/source-disk b/lang/basic/1.8.7/source-disk new file mode 100644 index 0000000..c87f56d --- /dev/null +++ b/lang/basic/1.8.7/source-disk @@ -0,0 +1 @@ +informatikpaket/02_basic.img diff --git a/lang/basic/1.8.7/src/BASIC.Administration b/lang/basic/1.8.7/src/BASIC.Administration new file mode 100644 index 0000000..6df6854 --- /dev/null +++ b/lang/basic/1.8.7/src/BASIC.Administration @@ -0,0 +1,1886 @@ +(***************************************************************************) +(* *) +(* Zweite von drei Dateien des EUMEL-BASIC-Systems *) +(* *) +(* Autor: Heiko Indenbirken *) +(* Überarbeitet von: Rudolf Ruland und Michael Overdick *) +(* *) +(* Stand: 27.10.1987 *) +(* *) +(***************************************************************************) + +PACKET basic errors DEFINES basic error, (* Autor: Heiko Indenbirken *) + return error, (* Stand: 26.08.1987/rr/mo *) + basic warning: + +TEXT VAR erste zeile, + message; +LET errorsize = 40; +LET ERROR = STRUCT (INT no, TEXT msg); + +ROW errorsize ERROR CONST error msg :: ROW errorsize ERROR : +(ERROR:( 1, "NEXT ohne FOR"), + ERROR:( 2, "Syntaxfehler:"), + ERROR:( 5, "Fehlerhafter Funktionsaufruf"), + ERROR:( 8, "Zeile mit dieser Nummer existiert nicht"), + ERROR:(10, "Das Feld ist bereits dimensioniert"), + ERROR:(13, "Falscher Typ:"), + ERROR:(15, "Text zu lang"), + ERROR:(18, "Undefinierte 'user function'"), + ERROR:(22, "Ausdruck erwartet"), + ERROR:(26, "FOR ohne NEXT"), + ERROR:(29, "WHILE ohne WEND"), + ERROR:(30, "WEND ohne WHILE"), + ERROR:(51, "Interner Fehler"), + ERROR:(80, "Fehlerhafte Zeilennummer"), + ERROR:(81, "Falsche Reihenfolge der Zeilennummern"), + ERROR:(82, "Falscher Typ des Operanden:"), + ERROR:(83, "Falscher Typ der Operanden:"), + ERROR:(84, "Falsche Felddimension:"), + ERROR:(85, "Rekursive Funktionsdefinition"), + ERROR:(86, "Fehlerhafte Laufvariable:"), + ERROR:(87, "Fehlerhafte Bereichsangabe:"), + ERROR:(88, "Fehlerhafte Dimensionierung:"), + ERROR:(89, "Parametervariable kommt mehrmals vor"), + ERROR:(90, "AS ohne NAME"), + ERROR:(91, "BASE ohne OPTION"), + ERROR:(92, "ELSE ohne IF"), + ERROR:(93, "STEP ohne FOR"), + ERROR:(94, "TAB ohne (L)PRINT"), + ERROR:(95, "THEN ohne IF"), + ERROR:(96, "TO ohne Zusammenhang"), + ERROR:(97, "USING ohne (L)PRINT"), + ERROR:(98, "Unbekannte Funktion,"), + ERROR:(99, "Unbekannte Prozedur,"), + ERROR:(100,"Nicht implementiert"), + ERROR:(101,"SUB ohne GO"), + ERROR:(102,"GO ohne TO oder SUB"), + ERROR:(103,"Accessrecht VAR erwartet, CONST gefunden"), + ERROR:(104,"Funktionsaufruf ohne Zusammenhang"), + ERROR:(105,"Nach OPTION BASE ist nur 0 oder 1 erlaubt"), + ERROR:(106,"Bei SWAP nur gleiche Variablentypen erlaubt")); + +TEXT PROC errortext (INT CONST no): + INT VAR i; + FOR i FROM 1 UPTO errorsize + REP IF errormsg [i].no = no + THEN LEAVE errortext WITH errormsg [i].msg FI + PER; + "Unbekannter BASIC-Fehler #" + text (no) . +END PROC errortext; + +PROC basic error (TEXT CONST packet, + INT CONST error nr, + INT CONST line nr, + INT CONST statement nr, + TEXT CONST position, addition, + BOOL CONST leave statement): + erste zeile aufbauen; + einfache fehlermeldung aufbauen; + diese auf terminal ausgeben; + diese in sysout datei ausgeben wenn noetig; (* F20/rr *) + fehlermeldung in fehlerdatei ausgeben; + IF leave statement (* DEF/mo *) + THEN errorstop (101, packet + "-Fehler") + FI. + +erste zeile aufbauen: + IF line nr = 0 AND statement nr = 0 + THEN erste zeile := "FEHLER" + ELSE erste zeile := "FEHLER (Dateizeile "; + erste zeile CAT text (line nr); + erste zeile CAT ") in Zeile "; + erste zeile CAT text (statement nr); + FI; + + erste zeile CAT " bei >> "; + erste zeile CAT position; + erste zeile CAT " << : " . + +einfache fehlermeldung aufbauen: + message := " "; + message CAT error text (error nr); + message CAT " " . + +diese auf terminal ausgeben: (* F20/rr *) + display (""13""10""); + display (erste zeile); + display (""13""10""); + display (message + addition); + display (""13""10"") . + +diese in sysout datei ausgeben wenn noetig : (* F20/rr *) + IF sysout <> "" + THEN putline (erste zeile); + putline (message + addition); + line; + FI . + +fehlermeldung in fehlerdatei ausgeben: + note (erste zeile); + note line; + note (message); + note (addition); + note line . + +END PROC basic error; + +PROC basic warning (INT CONST line nr, (* mo *) + statement nr, + TEXT CONST warning text): +generate warning; +on screen; +in sysout file; +into the notebook. + +generate warning: + IF line nr = 0 AND statement nr = 0 + THEN erste zeile := "WARNUNG" + ELSE erste zeile := "WARNUNG (Dateizeile "; + erste zeile CAT text (line nr); + erste zeile CAT ") in Zeile "; + erste zeile CAT text (statement nr); + FI; + erste zeile CAT ": "; + erste zeile CAT warning text. + +on screen: + display (""13""10""); + display (erste zeile); + display (""13""10""). + +in sysout file: + IF sysout <> "" + THEN putline (erste zeile); + line; + FI. + +into the notebook: + IF warnings + THEN note (erste zeile); + note line + FI. + +END PROC basic warning; + +PROC return error: + errorstop (1003, "RETURN ohne GOSUB") +END PROC return error; + +END PACKET basic errors; + +PACKET basic types DEFINES symbol of, (* Autor: Heiko Indenbirken *) + type of, (* Stand: 07.09.1987/rr/mo *) + dim of, + shift, deshift, + reserved, + param list, + is bool op: + +LET (* S y m b o l T y p e n *) + any = 0, const = 1, var = 2, array = 3, + expr = 4, unused = 5, letter = 6, param = 7, + res word = 8, operator = 9, eos = 10, del = 11, + stat no = 12, eol = 13, eop = 14, + user fn = 20; (* DEF/mo *) +(* Operatoren *) +LET less equal = 28, unequal = 29, greater equal = 30; + +TEXT VAR dummy; + +TEXT PROC symbol of (INT CONST n) : + IF n < 0 + THEN ""19"" + symbol of (-n) + ELSE SELECT n OF + CASE less equal : "<=" + CASE unequal : "<>" + CASE greater equal : ">=" + + CASE eos : "EOS" + CASE eol : "EOL" + CASE eop : "EOF" + OTHERWISE : character END SELECT + FI . + +character : + IF n > 32 AND n < 128 + THEN code (n) + ELIF n >= 128 AND n <= 255 + THEN res word of (n) + ELSE "%" + subtext (text (n+1000), 2) + " " FI . + +END PROC symbol of; + +TEXT PROC type of (INT CONST n) : + SELECT n OF + CASE any : "ANY" + CASE const : "Konstante" + CASE var : "Variable" + CASE array : "Feld" + CASE expr : "Ausdruck" + CASE unused : " -?- " + CASE letter : "Buchstabe" + CASE param : "Parameter" + CASE res word : "reserviertes Wort" + CASE operator : "Operator" + CASE eos : "EOS" + CASE del : "Trennzeichen" + CASE stat no : "Zeilennumer" + CASE eol : "EOL" + CASE eop : "EOF" + CASE user fn : "'user function'" (* DEF/mo *) + OTHERWISE "?TYPE #" + text (n) ENDSELECT. +END PROC type of; + +TEXT PROC dim of (TEXT CONST parameter): + IF parameter = "" + THEN "" + ELSE base limits and size FI . + +base limits and size: + INT CONST dimension :: (LENGTH parameter DIV 2) - 2; + TEXT VAR result :: text (parameter ISUB dimension+1); + INT VAR i; + result CAT ": ["; + FOR i FROM 1 UPTO dimension-1 + REP result CAT text (parameter ISUB i); + result CAT ", " + PER; + result CAT text (parameter ISUB dimension); + result CAT "] "; + result CAT text (parameter ISUB dimension+2); + result . + +END PROC dim of; + +TEXT PROC param list (INT CONST first, no): + IF no < first + THEN "keine" + ELSE parameter list FI . + +parameter list: + INT VAR i; + TEXT VAR result :: "("; + FOR i FROM first UPTO no + REP result CAT dump (dtype (i)); + IF i = no + THEN result CAT ")" + ELSE result CAT ", " FI + PER; + result . + +END PROC param list; + +TEXT PROC shift (TEXT CONST word) : + INT VAR i; + dummy := word; + FOR i FROM 1 UPTO length (word) + REP shift char PER; + dummy . + +shift char: + INT VAR local letter :: code (dummy SUB i); + IF 97 <= local letter AND local letter <= 122 + THEN replace (dummy, i, code (local letter - 32)) FI . + +END PROC shift; + +TEXT PROC deshift (TEXT CONST word) : + INT VAR i; + dummy := word; + FOR i FROM 1 UPTO length (word) + REP deshift char PER; + dummy . + +deshift char: + INT VAR local letter :: code (dummy SUB i); + IF 65 <= local letter AND local letter <= 90 + THEN replace (dummy, i, code (local letter + 32)) FI; + +END PROC deshift; + +(* Verwaltung der Reservierten BASIC-Wörter *) +LET first operator = 249, (* MOD NOT AND OR XOR EQV IMP *) + first bool op = 250; (* 249 250 251 252 253 254 255 *) + +INT VAR index; +ROW 9 TEXT VAR res words :: ROW 9 TEXT : +("", + ""129"as"163"go"167"if"188"on"217"to"252"or", + ""128"abs"130"asc"131"atn"141"cos"142"cvd"143"cvi"145"def"150"dim"152"end"153"eof"154"erl"155"err"157"exp"159"fix"160"for"161"fre"162"get"172"int"175"len"176"let"178"loc"179"log"191"out"192"pos"194"put"202"rnd"197"rem"204"sgn"205"sin"207"spc"208"sqr"214"tab"215"tan"221"val"227"cls"234"usr"235"sub"249"mod"250"not"251"and"253"xor"254"eqv"255"imp", + ""132"base"133"call"134"cdbl"136"chr$"137"cint"144"data"151"else"165"goto"166"hex$"173"kill"177"line"181"lset"182"mid$"183"mkd$"184"mki$"185"name"186"next"187"oct$"189"open"196"read"203"rset"209"step"210"stop"211"str$"213"swap"216"then"219"tron"222"wait"223"wend"228"erm$"230"lpos", + ""135"chain"138"clear"139"close"156"error"158"field"164"gosub"169"input"171"instr"174"left$"193"print"218"troff"220"using"224"while"225"width"226"write"231"time$"232"date$"233"timer", + ""140"common"146"defdbl"147"defint"148"defsng"149"defstr"168"inkey$"170"input$"180"lprint"190"option"199"resume"200"return"201"right$"206"space$"229"csrlin", + ""198"restore"212"string$", + "", + ""195"randomize"); + +BOOL PROC reserved (TEXT CONST name, INT VAR no, type): + IF reserve is not possible COR not found within res words + THEN FALSE + ELSE no := code (this words SUB (index-1)); + type := res word or op; + TRUE + FI . + +reserve is not possible: + INT CONST len :: length (name); + len < 2 OR len > 9 . + +not found within res words: + index := pos (this words, name); + index = 0 . + +this words: + res words [len] . + +res word or op: + IF no >= first operator + THEN operator + ELSE res word FI . + +END PROC reserved; + +INT PROC reserved (TEXT CONST name): + IF reserve is not possible COR not found within res words + THEN 0 + ELSE code (this words SUB (index-1)) FI . + +reserve is not possible: + INT CONST len :: length (name); + len < 2 OR len > 9 . + +not found within res words: + index := pos (this words, name); + index = 0 . + +this words: + res words [len] . + +END PROC reserved; + +TEXT PROC res word of (INT CONST no): + INT VAR i; + FOR i FROM 2 UPTO 9 + REP index := pos (res words [i], code (no)); + IF index > 0 + THEN LEAVE res word of WITH shift (this name) FI + PER; + "" . + +this name: + subtext (res words [i], index+1, next code) . + +next code: + INT VAR c := pos (res words [i], ""127"", ""255"", index+1); + IF c = 0 + THEN length (res words [i]) + ELSE c-1 FI . + +END PROC res word of; + +BOOL PROC is bool op (INT CONST no): (* mo *) + no >= first bool op +END PROC is bool op; + +END PACKET basic types; + +PACKET basic table handling DEFINES init table, (* Autor: Heiko Indenbirken *) + put name, (* Stand: 13.08.1987/rr/mo *) + known, name of, + remember, + recognize, + table entries, + hash table, next table, + scope compulsory: (* DEF/mo *) + +LET hash length = 1024, + hash length minus one = 1023, + start of name table = 256, + table length = 4500; + +LET SYMBOL = STRUCT (INT type, ADDRESS adr, DTYPE data, TEXT dim); +LET TABLE = STRUCT (INT entries, + ROW hash length INT hash table, + ROW table length INT next, + ROW table length TEXT name table, + ROW table length SYMBOL symbol table); + +DATASPACE VAR table space; +BOUND TABLE VAR table; +INITFLAG VAR tab := FALSE; +SYMBOL CONST nilsymbol :: SYMBOL:(0, LOC 0, void type, ""); +INT VAR i; +BOOL VAR compulsory with scope :: TRUE; (* DEF/mo *) + +PROC init table: + IF NOT initialized (tab) + THEN table space := nilspace; + table := table space; + FI; + table.entries := start of name table; + FOR i FROM 1 UPTO hash length + REP table.hash table [i] := 0 PER; + compulsory with scope := TRUE; (* DEF/mo *) + +END PROC init table; + +PROC put name (TEXT CONST scope, name, INT VAR pointer): (* DEF/mo *) + IF compulsory with scope + THEN put name (scope + name, pointer) + ELIF NOT in table + THEN put name (name, pointer) + FI. + +in table: + hash (scope + name, pointer); + pointer := hash table (pointer); + WHILE not end of chain + REP IF name is found THEN LEAVE in table WITH TRUE FI; + pointer := table. next (pointer); + PER; + FALSE . + +name is found: + table.name table [pointer] = scope + name. + +not end of chain: + pointer > 0 . + +END PROC put name; + +PROC put name (TEXT CONST name, INT VAR pointer): + IF no entry in hash table + THEN create a new chain + ELSE create a new entry in chain FI; + insert name in name table . + +no entry in hash table: + INT VAR hash index; + hash (name, hash index); + table.hash table [hash index] = 0 . + +create a new chain: + table.hash table [hash index] := table.entries . + +create a new entry in chain: + pointer := table.hash table [hash index]; + REP IF name is found + THEN LEAVE put name + ELIF end of chain + THEN table.next [pointer] := table.entries; + LEAVE create a new entry in chain + ELSE pointer := next pointer FI + PER . + +name is found: + table.name table [pointer] = name. + +end of chain: + INT CONST next pointer := table.next [pointer]; + next pointer = 0 . + +insert name in name table: + IF table.entries >= table length + THEN errorstop ("volle Namenstabelle") FI; + + pointer := table.entries; + table.symbol table [pointer] := nilsymbol; + table.name table [pointer] := name; + table.next [pointer] := 0; + table.entries INCR 1 . + +END PROC put name; + +PROC hash (TEXT CONST name, INT VAR index) : + INT VAR j; + index := 0; + FOR j FROM 1 UPTO length (name) + REP addmult cyclic PER; + index INCR 1 . + +addmult cyclic : + index INCR index ; + IF index > hash length minus one + THEN wrap around FI; + index := (index + code (name SUB j)) MOD hash length minus one . + +wrap around: + index DECR hash length minus one . + +ENDPROC hash ; + +INT PROC table entries: + table.entries +END PROC table entries; + +INT PROC hash table (INT CONST n): + table.hash table [n] +END PROC hash table; + +INT PROC next table (INT CONST n): + table.next [n] +END PROC next table; + +TEXT PROC name of (INT CONST index): + IF index < 0 + THEN errorstop ("PROC name of: negativer Index"); "" + ELIF index < start of name table + THEN symbol of (index) + ELIF index <= table.entries + THEN table.name table (index) + ELSE errorstop ("PROC name of: Index größer als nametable"); + "" + FI + +END PROC name of; + +PROC recognize (INT CONST symb, type, ADDRESS CONST adr, DTYPE CONST data, TEXT CONST dim): + symbol.type := type; + symbol.adr := adr; + symbol.data := data; + symbol.dim := dim . + +symbol: table.symboltable [symb] . +END PROC recognize; + +PROC remember (INT CONST symb, INT VAR type, ADDRESS VAR adr, DTYPE VAR data, TEXT VAR dim): + SYMBOL CONST symbol := table.symboltable [symb]; + type := symbol.type; + adr := symbol.adr; + data := symbol.data; + dim := symbol.dim +END PROC remember; + +BOOL PROC known (INT CONST symb) : + table.symboltable [symb].type > 0 +END PROC known; + +PROC scope compulsory (BOOL CONST new state): (* DEF/mo *) + compulsory with scope := new state +END PROC scope compulsory; + +END PACKET basic table handling; + +PACKET basic scanner DEFINES begin scanning, (* Autor: Heiko Indenbirken *) + next symbol, (* Stand: 27.10.1987/rr/mo *) + next data, + next statement, + define chars, + scan line, + scan line no, (* F29/rr *) + get data types of input vars, (* F25/rr *) + basic error, + basic warning, + basic list, + set scope, + scanner scope: + + +LET (* S y m b o l T y p e n *) + any = 0, const = 1, var = 2, array = 3, + res word= 8, operator= 9, eos = 10, del =11, + stat no = 12, user fn = 20; (* DEF/mo *) + +LET (* S y m b o l z e i c h e n *) + less = 60, greater = 62, + less equal = 28, unequal = 29, greater equal = 30, + point = 46, eol = 13, eop = 14, + go = 163, gosub = 164, goto = 165, + sub = 235, to = 217; + +LET name chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz.0123456789!#$%", + quote = """", open bracket = "(", + comma = ",", close bracket = ")", + colon = ":", + exponent chars= "dDeE"; + +FILE VAR source file; +TEXT VAR defint chars, defstr chars, record, letter, + scope, new name; (* DEF/mo *) +REAL VAR r dummy; +INT VAR act stat no, record no, rec len, scan pos, i dummy; +BOOL VAR eol generated, at line begin, listing := FALSE; + +PROC define chars (TEXT CONST begin, end, DTYPE CONST data): + INT VAR i; + FOR i FROM code (begin) UPTO code (end) + REP IF data = int type + THEN defint chars CAT code (i) + ELIF data = text type + THEN defstr chars CAT code (i) + FI + PER . + +END PROC define chars; + + +PROC scanline (TEXT VAR line, INT VAR col): + line := record; + col := scan pos +END PROC scanline; + +INT PROC scan line no : record no END PROC scan line no; + + +PROC get data types of input vars (ROW 100 DTYPE VAR input var data, (* F25/rr *) + INT VAR number input vars) : + + TEXT VAR first var char; + INT VAR var pos := scan pos; + to begin of actual var; + REP get next input var; + skip brackets if necessary; + IF var char <> comma THEN LEAVE get data types of input vars FI; + skip comma; + PER; + + . var char : record SUB var pos + + . to begin of actual var : + WHILE pos (name chars, var char) <> 0 REP var pos DECR 1 PER; + var pos INCR 1; + number input vars := 0; + + . get next input var : + first var char := deshift (var char); + WHILE pos (name chars, var char) <> 0 REP var pos INCR 1 PER; + var pos DECR 1; + number input vars INCR 1; + input var data (number input vars) := var datatype (first var char, var char); + var pos := pos (record, ""33"", ""255"", var pos + 1); + + . skip brackets if necessary : + IF var char = open bracket + THEN INT VAR bracket counter := 1; + REP count bracket UNTIL bracket counter = 0 PER; + var pos := pos (record, ""33"", ""255"", var pos + 1); + FI; + + . count bracket : + INT CONST open := pos (record, open bracket, var pos + 1), + close := pos (record, close bracket, var pos + 1); + IF open > 0 + THEN IF close > 0 + THEN IF open > close + THEN close bracket found + ELSE open bracket found + FI; + ELSE open bracket found + FI; + ELSE IF close > 0 + THEN close bracket found + ELSE LEAVE get data types of input vars + FI; + FI; + + . open bracket found : + bracket counter INCR 1; + var pos := open; + + . close bracket found : + bracket counter DECR 1; + var pos := close; + + . skip comma : + var pos := pos (record, ""33"", ""255"", var pos + 1); + +END PROC get data types of input vars; + + +PROC begin scanning (FILE VAR basic file): + enable stop; + source file := basic file; + to first record (source file); + col (source file, 1); + IF eof (source file) + THEN errorstop ("Datei ist leer") FI; + + defint chars := ""; + defstr chars := ""; + scope := ""; (* DEF/mo *) + act stat no := 0; + read record (source file, record); + rec len := length (record); + scan pos := 0; + record no := 1; + eol generated := FALSE; + at line begin := TRUE; + IF listing + THEN line; + putline (record); + IF sysout <> "" + THEN cout (record no) + FI + ELSE cout (record no) + FI. + +END PROC begin scanning; + +PROC next statement: + IF eof (source file) + THEN errorstop (99, "") + ELSE eol generated := FALSE; + at line begin := TRUE; + down (source file); + read record (source file, record); + rec len := length (record); + scan pos := 0; + record no INCR 1; + FI; + IF listing + THEN putline (record); + IF sysout <> "" + THEN cout (record no) + FI + ELSE cout (record no) + FI. + +END PROC next statement; + +PROC next symbol (TEXT VAR name, INT VAR no, type, DTYPE VAR data): + enable stop; + clear symbol; + IF eol generated + THEN next statement FI; + + IF eol reached + THEN generate eol + ELIF at line begin CAND stat no found (* F15/rr *) + THEN generate stat no + ELSE generate chars FI . + +clear symbol: + name := ""; + no := 0; + type := any; + data := void type . + +eol reached: + scan pos := pos (record, ""33"", ""255"", scan pos+1); + scan pos = 0 . + +generate eol : + IF eof (source file) + THEN name := "EOF"; no := eop; type := eos + ELSE name := "EOL"; no := eol; type := eos FI; + eol generated := TRUE . + +stat no found: (* F15/rr *) + at line begin := FALSE; + pos ("0123456789", act char) <> 0 . + +generate stat no: (* F15/rr *) + INT CONST next scan pos := last number pos; + name := subtext (record, scan pos, next scan pos); + act stat no := int (name); + scan pos := next scan pos; + no := act stat no; type := stat no . + +last number pos : (* F15/rr *) + INT CONST high := pos (record, ""058"", ""255"", scan pos), + low := pos (record, ""032"", ""047"", scan pos); + IF high > 0 + THEN IF low > 0 + THEN min (high, low) - 1 + ELSE high - 1 + FI + ELIF low > 0 + THEN low - 1 + ELSE LENGTH record + FI . + +generate chars: + SELECT code (act char) OF + CASE 32: next symbol (name, no, type, data) (* Space *) + CASE 34: generate text denoter (* " *) + CASE 39: generate eol (* ' *) + CASE 42, 43, 45, 47, 92, 94, 61: generate operator (* *,+,-,/,\,^,=*) + CASE 60: generate less op (*<, <=, <> *) + CASE 62: generate greater op (*>, >= *) + CASE 46: treat point (* . *) + CASE 48, 49, 50, 51, 52, 53, 54, 55, 56, 57: + generate numeric const (* 0 - 9 *) + CASE 58: generate eos (* : *) + CASE 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, + 82, 83, 84, 85, 86, 87, 88, 89, 90, 97, 98, 99, 100, 101, 102, 103, + 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, + 118, 119, 120, 121, 122, (* small and large letters *) + generate res word or id + OTHERWISE generate delimiter END SELECT . + +generate text denoter: + get text const (name, data); + type := const . + +generate operator: + name := act char; no := code (name); type := operator . + +generate less op: + IF next char = "=" + THEN name := "<="; no := less equal; skip char + ELIF next char = ">" + THEN name := "<>"; no := unequal; skip char + ELSE name := "<"; no := less FI; + type := operator . + +generate greater op: + IF next char = "=" + THEN name := ">="; no := greater equal; skip char + ELSE name := ">"; no := greater; FI; + type := operator . + +treat point: + IF pos ("0123456789", next char) <> 0 + THEN generate numeric const + ELSE name := "."; + no := point; + type := del + FI. + +generate numeric const: + get numeric const (name, data); + type := const . + +last name char: + name SUB LENGTH name . + +generate eos: + name := ":"; no := eos; type := eos . + +generate res word or id: + get name chars; + IF reserved (deshift name, no, type) + THEN IF type = res word AND no = go + THEN treat go + FI + ELSE IF function name + THEN data := ftn datatype; + type := user fn + ELSE data := var datatype (deshift (name) SUB 1, last name char); + type := var or array + FI; + put name (scope, deshift name, no) + FI. + +treat go: + next symbol (new name, no, type, data); + IF no = to AND type = res word + THEN name CAT new name; + no := goto + ELIF no = sub AND type = res word + THEN name CAT new name; + no := gosub + ELSE scan error (102, name, "") + FI. + +get name chars: + TEXT VAR deshift name :: ""; + INT VAR begin of name :: scan pos; + FOR scan pos FROM scan pos UPTO rec len + WHILE name chars found + REP deshift name CAT deshifted char PER; + scan pos DECR 1; + name := subtext (record, begin of name, scan pos). + +name chars found: + pos (name chars, act char) > 0 . + +function name: + subtext (deshift name, 1, 2) = "fn" . + +ftn datatype: + IF last name char = "$" + THEN text type + ELIF last name char = "%" + THEN int type + ELSE real type FI . + +var or array: + IF array name + THEN name CAT "()"; + deshift name CAT "()"; (* F30/rr *) + array + ELSE var FI . + +array name: + next scan char = "(" . + +deshifted char: + letter := act char; + IF letter >= "A" AND letter <= "Z" + THEN code (code (letter) + 32) + ELSE letter FI . + +generate delimiter: + name := act char; no := code (name); type := del . + +next scan char: record SUB pos (record, ""33"", ""255"", scan pos+1). +next char: (record SUB scan pos + 1) . +act char: record SUB scan pos . +skip char: scan pos INCR 1 . +END PROC next symbol; + +DTYPE PROC var datatype (TEXT CONST first name char, last name char) : + + IF last name char = "!" OR last name char = "#" + THEN real type + ELIF last name char = "$" + THEN text type + ELIF last name char = "%" + THEN int type + ELIF pos (defint chars, first name char) > 0 + THEN int type + ELIF pos (defstr chars, first name char) > 0 + THEN text type + ELSE real type FI . + +END PROC var datatype; + +BOOL PROC next data (TEXT VAR data text, DTYPE VAR data type) : (* F17/rr *) + + data type := void type; + IF no more data + THEN scan pos := rec len; + data text := ""; + FALSE + ELIF quoted string + THEN get quoted string; + TRUE + ELSE get unquoted string; + TRUE + FI + + . no more data : + scan pos := pos (record, ""33"", ""255"", scan pos+1); + scan pos = 0 + + . quoted string : + (record SUB scan pos) = quote + + . get quoted string : + get text const (data text, data type); + + . get unquoted string : + INT CONST comma or colon pos 1 := position of comma or colon minus one; + data text := compress (subtext (record, scan pos, comma or colon pos 1)); + scan pos := comma or colon pos 1; + + . position of comma or colon minus one : + INT CONST colon pos := pos (record, colon, scan pos), + comma pos := pos (record, comma, scan pos); + IF colon pos > 0 + THEN IF comma pos > 0 + THEN min (colon pos, comma pos) - 1 + ELSE colon pos - 1 + FI + ELSE IF comma pos > 0 + THEN comma pos - 1 + ELSE LENGTH record + FI + FI + +END PROC next data; + +PROC get numeric const (TEXT VAR value, DTYPE VAR data): + get sign; + get const; + check datatype . + +get sign: + IF act char = "-" + THEN value := "-"; + scan pos INCR 1 + ELIF act char = "+" + THEN value := "+"; + scan pos INCR 1 + ELSE value := "" FI . + +get const: + get digits; + get point; + get digits; + get exponent . + +get digits: + FOR scan pos FROM scan pos UPTO rec len + WHILE digit found + REP value CAT act char PER . + +get point: + IF act char = "." + THEN value CAT "."; + scan pos INCR 1 + ELIF pos (exponent chars, act char) > 0 + THEN value CAT ".0" + ELSE LEAVE get const FI . + +get exponent: + IF pos (exponent chars, act char) > 0 (* F1/rr *) + THEN value CAT "e"; + scan pos INCR 1; + evtl get sign; + get digits + FI . + +evtl get sign: + IF act char = "+" OR act char = "-" + THEN value CAT act char; + scan pos INCR 1 + FI . + +digit found: + "0" <= act char AND act char <= "9" . + +check datatype: + IF act char = "%" + THEN IF integer ok (value) + THEN data := int type + ELSE scan error (2, value, "INT-Konstante nicht korrekt") FI + ELIF act char = "!" OR act char = "#" + THEN IF real ok (value) + THEN data := real type + ELSE scan error (2, value, "REAL-Konstante nicht korrekt") FI + ELIF integer ok (value) + THEN scan pos DECR 1; data := int type + ELIF real ok (value) + THEN scan pos DECR 1; + data := real type + ELSE scan error (2, value, "Numerische Konstante nicht korrekt") FI . + +act char: record SUB scan pos . +END PROC get numeric const; + +PROC get text const (TEXT VAR value, DTYPE VAR data): + INT CONST quote 1 := scan pos; + scan pos := pos (record, """", scan pos+1); + IF quote 1 < scan pos + THEN value := subtext (record, quote 1+1, scan pos-1); + data := text type + ELSE scan error (15, subtext (record, quote 1), "("" fehlt)") FI . + +END PROC get text const; + +BOOL PROC integer ok (TEXT VAR zahl): + disable stop; + i dummy := int (zahl); + IF is error + THEN clear error; + FALSE + ELIF last conversion ok + THEN zahl := ""0""0""; + replace (zahl, 1, i dummy); + TRUE + ELSE FALSE FI . + +END PROC integer ok; + +BOOL PROC real ok (TEXT VAR zahl): + disable stop; + r dummy := real (zahl); + IF is error + THEN clear error; + FALSE + ELIF last conversion ok + THEN zahl := ""0""0""0""0""0""0""0""0""; + replace (zahl, 1, r dummy); + TRUE + ELSE FALSE FI . + +END PROC real ok; + +PROC basic error (INT CONST no, TEXT CONST name, addition): + basic error ("Compiler", no, record no, act stat no, name, addition, TRUE) +END PROC basic error; + +PROC basic error (INT CONST no, TEXT CONST name, addition, BOOL CONST leave statement): + basic error ("Compiler", no, record no, act stat no, name, addition, leave statement) +END PROC basic error; + +PROC scan error (INT CONST no, TEXT CONST name, addition): + basic error ("Scanner", no, record no, act stat no, name, addition, TRUE) +END PROC scan error; + +PROC basic warning (TEXT CONST warning text): (* mo *) + basic warning (record no, act stat no, warning text) +END PROC basic warning; + +PROC basic list (BOOL CONST t): + listing := t +END PROC basic list; + +BOOL PROC basic list: + listing +END PROC basic list; + +PROC set scope (TEXT CONST new scope): (* DEF/mo *) + scope := new scope +END PROC set scope; + +TEXT PROC scanner scope: (* DEF/mo *) + scope +END PROC scanner scope; + +END PACKET basic scanner; + + +PACKET basic stat no DEFINES init stat no, (* Autor: Heiko Indenbirken *) + stat no pos, (* Stand: 27.10.1987/rr/mo *) + label pos, + all stat no: + +LET nil = ""; + +TEXT VAR found stat no :: nil; +INT VAR i, akt stat no :: 0, found no :: 0; + +PROC init stat no (FILE VAR f, INT VAR error no): (* F21/rr *) +(*Die Datei 'f' muß im 'modify-Mode' sein. *) + INT VAR line no; + akt stat no := -1; (* F28/rr *) + found no := 0; + found stat no := nil; + error no := 0; (* F21/rr *) + to first record (f); + col (f, 1); + disable stop; + FOR line no FROM 1 UPTO 4000 + REP exec (PROC (TEXT CONST, INT CONST) check, f, line no); + IF is error THEN check error FI; + IF eof (f) + THEN LEAVE init stat no + ELSE down (f) FI + PER; + +. check error : (* F21/rr *) + IF error code = 100 + THEN clear error; + error no INCR 1; + ELSE LEAVE init stat no; + FI; + +END PROC init stat no; + +PROC check (TEXT CONST record, INT CONST line no): + IF statement no vorhanden + THEN remember statement no FI . + +statement no vorhanden: (* F15/rr *) + INT CONST first number pos := pos (record, ""048"", ""057"", 1); + first number pos > 0 CAND first number pos = first non blank pos . + +first non blank pos : (* F15/rr *) + pos (record, ""033"", ""255"", 1) . + +remember statement no: + get statement no; + IF neue nummer ist groesser als vorherige + THEN akt stat no := neue nummer; + cout (neue nummer); + found no INCR 1; + found stat no CAT mki (neue nummer) + ELSE basic error ("Stat no", 81, line no, neue nummer, number, + "Letzte Zeilennummer davor: " + text (akt stat no), TRUE) + FI . + +get statement no : (* F15/rr *) + disable stop; + TEXT CONST number := subtext (record, first number pos, last number pos); + INT VAR neue nummer := int (number); + IF NOT last conversion ok OR is error + THEN clear error; + basic error ("Stat no", 80, line no, akt stat no, number, + "Die Zeilennummer muß im Bereich 0-32767 liegen", TRUE) + FI; + enable stop . + +last number pos : (* F15/rr *) + INT CONST high := pos (record, ""058"", ""255"", first number pos), + low := pos (record, ""032"", ""047"", first number pos); + IF high > 0 + THEN IF low > 0 + THEN min (high, low) - 1 + ELSE high - 1 + FI + ELIF low > 0 + THEN low - 1 + ELSE LENGTH record + FI . + +neue nummer ist groesser als vorherige: + neue nummer > akt stat no . + +END PROC check; + +INT PROC stat no pos (INT CONST stat no): + FOR i FROM found no DOWNTO 1 + REP IF (found stat no ISUB i) = stat no + THEN LEAVE stat no pos WITH i FI + PER; + 0 +END PROC stat no pos; + +INT PROC label pos (INT CONST stat no): + FOR i FROM found no DOWNTO 1 + REP IF (found stat no ISUB i) = stat no + THEN LEAVE label pos WITH i FI + PER; + basic error (8, text (stat no), nil); (* F16/rr *) + 0 +END PROC label pos; + +PROC all stat no (TEXT VAR stat no, INT VAR no): + stat no := found stat no; + no := found no +END PROC all stat no; + +END PACKET basic stat no; + +PACKET basic storage DEFINES init storage, (* Autor: Heiko Indenbirken *) + next local adr, (* Stand: 12.06.86 *) + next ref, + local adr, + local storage, + type size, + quiet type: + + + +LET ref length = 2; + +INT VAR quiet size, quiet align; +ADDRESS VAR loc adr, free loc adr; +DTYPE VAR quiet value; +identify ("QUIET", quiet size, quiet align, quiet value); + +PROC init storage: + free loc adr := LOC 0; + loc adr := LOC 0; + +END PROC init storage; + +(* Verwaltung der lokalen Addressen für Zwischenergebnisse *) +ADDRESS PROC next local adr (DTYPE CONST type): + INT VAR type len :: type size (type); + loc adr := free loc adr; + adjust (loc adr, type len); + free loc adr := loc adr + type len; + loc adr . + +END PROC next local adr; + +ADDRESS PROC next ref: + loc adr := free loc adr; + adjust (loc adr, ref length); + free loc adr := loc adr + ref length; + loc adr . + +END PROC next ref; + +ADDRESS PROC local adr: + loc adr +END PROC local adr; + +INT PROC local storage: + int (subtext (dump (free loc adr), 6)) +END PROC local storage; + +INT PROC type size (DTYPE CONST type): + IF type = int type OR type = bool type + THEN 1 + ELIF type = row type + THEN 2 + ELIF type = real type + THEN 4 + ELIF type = text type + THEN 8 + ELIF type = quiet value + THEN quiet size + ELSE errorstop ("Unbekannter DTYPE: " + dump (type)); 0 FI . + +END PROC type size; + +DTYPE PROC quiet type: + quiet value +END PROC quiet type; + +END PACKET basic storage; + +PACKET basic identify DEFINES (* Autor: Heiko Indenbirken *) + (* Stand: 20.08.1987/rr/mo *) + identify, + convert paramfield, + dump ftn, + is basic function: (* mo *) + +LET nil = ""; + +LET ENTRY = STRUCT (TEXT param, INT no, next, OPN opn, DTYPE result); + +ROW 256 ENTRY VAR ftn table; + +clear ftn table; +init ftn names; +init int operator; +init real operator; +init text operator; +init predefined funktions; + +PROC dump ftn (INT CONST n, TEXT VAR param, INT VAR no, next, + OPN VAR opn, DTYPE VAR result): + param := ftn table [n].param; + no := ftn table [n].no; + next := ftn table [n].next; + opn := ftn table [n].opn; + result := ftn table [n].result + +END PROC dump ftn; + +PROC identify (INT CONST ftn no, first, params, OPN VAR operation, BOOL VAR found): + TEXT VAR param; + INT VAR pos :: min (ftn no, 256); + convert paramfield (first, params, param); + REP IF param = ftn table [pos].param AND ftn no = ftn table [pos].no + THEN declare (params+1, ftn table [pos].result); + declare (params+1, 1); + operation := ftn table [pos].opn; + found := TRUE; + LEAVE identify + ELSE pos := ftn table [pos].next FI + UNTIL pos <= 0 PER; (* F14/rr *) + operation := nop; + found := FALSE . + +END PROC identify; + +PROC next free entry (INT VAR free pos): + FOR free pos FROM 1 UPTO 256 + REP IF ftn table [free pos].next < 0 AND ftn table [free pos].no = 0 (* mo *) + THEN LEAVE next free entry FI + PER; + errorstop ("Überlauf der Funktionstabelle") . + +END PROC next free entry; + +PROC convert paramfield (INT CONST first, params, TEXT VAR param): + INT VAR i; + param := nil; + FOR i FROM first UPTO params + REP param CAT datatype PER . + +datatype: + DTYPE CONST data :: dtype (i); + IF data = int type + THEN "I" + ELIF data = real type + THEN "R" + ELIF data = text type + THEN "T" + ELIF data = bool type + THEN "b" + ELSE errorstop ("Falscher DTYPE: " + dump (data)); + nil + FI . + +END PROC convert paramfield; + +PROC convert paramfield (TEXT CONST params, INT CONST first): + INT VAR i; + FOR i FROM first UPTO first+length (params)-1 + REP parameter (i, this type, 1, GLOB 0) PER . + +this type: + IF (params SUB i) = "I" + THEN int type + ELIF (params SUB i) = "R" + THEN real type + ELIF (params SUB i) = "T" + THEN text type + ELSE errorstop ("Unbekannter Typ: " + params); + undefined type + FI . + +END PROC convert paramfield; + +PROC init op (INT CONST ftn no, TEXT CONST param, ftn name): + IF elan opn found + THEN insert new opn in chain + ELSE errorstop ("PROC " + ftn name + " (" + param + ") nicht gefunden") FI . + +elan opn found: + OPN VAR opn; + BOOL VAR found; + convert paramfield (param, 1); + identify (ftn name, 1, length (param), opn, found); + found . + +insert new opn in chain: + INT VAR ftn pos :: ftn no; + REP IF end of chain found + THEN cat new entry in chain + ELIF free entry in chain found + THEN cover this entry + ELSE next entry FI + UNTIL ftn pos <= 0 PER . + +end of chain found: + act entry.next = 0 . + +cat new entry in chain: + INT VAR free pos; + next free entry (free pos); + act entry.next := free pos; + free entry := ENTRY:(param, ftn no, 0, opn, dtype (LENGTH param+1)); + LEAVE insert new opn in chain . + +free entry in chain found: + act entry.next = -1 . + +cover this entry: + act entry := ENTRY:(param, ftn no, 0, opn, dtype (LENGTH param+1)); + LEAVE insert new opn in chain . + +next entry: + ftn pos := act entry.next . + +act entry: ftn table [ftn pos] . +free entry: ftn table [free pos] . + +END PROC init op; + +BOOL PROC is basic function (INT CONST ftn no): (* mo *) + + pos (ftn names, code (ftn no)) <> 0 + +END PROC is basic function; + +. +clear ftn table: + INT VAR k; + FOR k FROM 1 UPTO 256 + REP ftn table [k] := ENTRY:(nil, 0,-1, nop, undefined type) PER . + +init ftn names: + TEXT CONST ftn names :: "+-*/\^<=>"28""29""30""249""251""252""253""254"" + + ""128""130""131""134""136""137""141""143""142"" + + ""153""154""155""157""159""161""166""168""170""171""172"" + + ""174""175""178""179""182""184""183""187""192"" + + ""201""202""204""205""206""207""208""211""212"" + + ""215""221""228""229""230""231""232""233""; + FOR k FROM 1 UPTO length (ftn names) + REP ftn table [ftn pos] := ENTRY:(nil, ftn pos,-1, nop, void type) PER . + +ftn pos: + code (ftn names SUB k) . + +init int operator: + init op ( 43, "II", "+"); + init op ( 45, "II", "-"); + init op ( 42, "II", "*"); + init op ( 47, "II", "/"); (* mo *) + init op ( 92, "II", "DIV"); (* mo *) + init op ( 94, "II", "^"); + init op ( 61, "II", "EQU"); + init op ( 29, "II", "UEQ"); + init op ( 60, "II", "LES"); + init op ( 28, "II", "LEQ"); + init op ( 62, "II", "GRE"); + init op ( 30, "II", "GEQ"); + init op (249, "II", "MOD"); (* mo *) + init op (251, "II", "AND"); + init op (252, "II", "OR"); + init op (253, "II", "XOR"); + init op (254, "II", "EQV"); + init op (255, "II", "IMP"). + +init real operator: + init op ( 43, "RR", "+"); + init op ( 45, "RR", "-"); + init op ( 42, "RR", "*"); + init op ( 47, "RR", "/"); + init op ( 92, "RR", "DIV"); (* mo *) + init op ( 94, "RR", "^"); + init op ( 61, "RR", "EQU"); + init op ( 29, "RR", "UEQ"); + init op ( 60, "RR", "LES"); + init op ( 28, "RR", "LEQ"); + init op ( 62, "RR", "GRE"); + init op ( 30, "RR", "GEQ"); + init op (249, "RR", "realmod"). (* mo *) + +init text operator: + init op ( 43, "TT", "+"); + init op ( 61, "TT", "EQU"); + init op ( 29, "TT", "UEQ"); + init op ( 60, "TT", "LES"); + init op ( 28, "TT", "LEQ"); + init op ( 62, "TT", "GRE"); + init op ( 30, "TT", "GEQ") . + +init predefined funktions: + init op (128, "I", "abs"); + init op (128, "R", "abs"); + init op (130, "T", "asc"); + init op (131, "R", "arctan"); + init op (131, "I", "arctan"); + init op (134, "I", "cdbl"); + init op (134, "R", "cdbl"); + init op (136, "I", "chr"); + init op (136, "R", "chr"); + init op (137, "R", "cint"); + init op (137, "I", "cint"); + init op (141, "R", "cos"); + init op (141, "I", "cos"); + init op (143, "T", "cvi"); + init op (142, "T", "cvd"); +# init op (153, "", "eof");# (* File *) + init op (154, "", "errorline"); + init op (155, "", "errorcode"); + init op (157, "R", "exp"); + init op (157, "I", "exp"); + init op (159, "R", "floor"); + init op (159, "I", "floor"); + init op (161, "I", "fre"); + init op (161, "R", "fre"); + init op (161, "T", "fre"); + init op (166, "I", "hex"); + init op (166, "R", "hex"); + init op (168, "", "incharety"); + init op (170, "I", "inchars"); + init op (170, "R", "inchars"); + init op (171, "TT", "instr"); + init op (171, "ITT", "instr"); + init op (171, "RTT", "instr"); + init op (172, "I", "ent"); + init op (172, "R", "ent"); + init op (174, "TI", "left"); + init op (174, "TR", "left"); + init op (175, "T", "length"); +# init op (178, "I", "line no");# (* File *) + init op (179, "R", "ln"); + init op (179, "I", "ln"); + init op (182, "TII", "mid"); + init op (182, "TI", "mid"); + init op (182, "TRR", "mid"); + init op (182, "TR", "mid"); + init op (183, "I", "mkd"); + init op (183, "R", "mkd"); + init op (187, "I", "oct"); + init op (187, "R", "oct"); + init op (192, "I", "pos"); + init op (192, "R", "pos"); + init op (201, "TI", "right"); + init op (201, "TR", "right"); + init op (202, "", "rnd"); (* F12/rr *) + init op (202, "I", "rnd"); + init op (202, "R", "rnd"); + init op (204, "I", "sign"); + init op (204, "R", "sign"); + init op (205, "R", "sin"); + init op (205, "I", "sin"); + init op (206, "I", "space"); + init op (206, "R", "space"); + init op (207, "I", "space"); + init op (207, "R", "space"); + init op (208, "R", "sqrt"); + init op (208, "I", "sqrt"); + init op (211, "I", "basictext"); + init op (211, "R", "basictext"); + init op (212, "IT", "string"); + init op (212, "RT", "string"); + init op (212, "II", "string"); + init op (212, "RR", "string"); + init op (212, "RI", "string"); + init op (212, "IR", "string"); + init op (215, "R", "tan"); + init op (215, "I", "tan"); + init op (221, "T", "val"); (* F18/rr *) + init op (228, "", "errormessage"); + init op (229, "", "csrlin"); + init op (230, "I", "lpos"); + init op (230, "R", "lpos"); + init op (231, "", "time"); + init op (232, "", "date"); + init op (233, "", "timer"). + +END PACKET basic identify; + +PACKET basic data handling (* Autor: R. Ruland *) + (* Stand: 23.10.87/mo *) + DEFINES init data, + data line, + data, read, + restore, + next int, + next real, + next text: + +LET (* R e s u l t T y p e n *) + stat code = 0, stat char = ""0"", + data code = 1, data char = ""1"", + text code = 2, text char = ""2"", + + int overflow = 4, + real overflow = 6; + +INT VAR type; +TEXT VAR data text :: "", number text; + +PROC init data: + + data text := "" + +END PROC init data; + + +PROC init data (TEXT VAR data, INT VAR data pos): + + data := data text; + data pos := 1 + +END PROC init data; + + +PROC restore (TEXT CONST data, INT VAR data pos, INT CONST line no): + + INT CONST data length :: LENGTH data; + data pos := 1; + WHILE data pos < data length + REP type := code (data SUB data pos); + data pos INCR 1; + SELECT type OF + CASE stat code : IF int value (data, data pos) >= line no + THEN LEAVE restore FI + CASE data code, text code : data pos INCR int value (data, data pos) + OTHERWISE : errorstop (1051, "Fehlerhaften Dateneintrag gefunden: " + text (type)) + ENDSELECT; + PER; + errorstop (1004, "RESTORE: Keine DATA-Anweisung in oder nach Zeile " + text (line no) + + " gefunden"); + +END PROC restore; + + +INT PROC next int (TEXT CONST data, INT VAR data pos): + + number text := next text (data, data pos); + disable stop; + INT VAR result := int (number text); + IF is error + THEN IF error code = int overflow THEN handle overflow FI; + ELIF NOT last conversion ok CAND number text <> "" + THEN errorstop (1013, "READ: Falscher Datentyp, " + number text + " ist kein INT") + FI; + result + + . handle overflow : + clear error; + result := result value; + IF cursor x pos <> 1 THEN next line FI; + basic out ("WARNUNG : INT-Überlauf bei READ, gefunden: " + number text); + next line; + + . result value : + IF (number text SUB 1) = "-" THEN minint ELSE maxint FI + +END PROC next int; + + +REAL PROC next real (TEXT CONST data, INT VAR data pos): + + number text := next text (data, data pos); + disable stop; + REAL VAR result := val (number text); + IF is error + THEN IF error code = real overflow OR error code = int overflow (* <- wegen Fehler in REAL PROC real (T C) *) + THEN handle overflow or underflow + FI; + ELIF NOT last conversion ok CAND number text <> "" + THEN errorstop (1013, "READ: Falscher Datentyp, " + number text + " ist kein REAL") + FI; + result + + . handle overflow or underflow : (* F23/rr *) + clear error; + IF cursor x pos <> 1 THEN next line FI; + basic out ("WARNUNG : " + overflow or underflow + " bei READ, gefunden: " + number text); + next line; + + . overflow or underflow : + IF is overflow + THEN result := sign * (max real - 0.99999999999994e120); (* <- wegen Fehler in TEXT PROC text (R C) *) + "REAL-Überlauf" + ELSE result := 0.0; + "REAL-Unterlauf" + FI + + . sign : + IF (number text SUB 1) = "-" THEN -1.0 ELSE 1.0 FI + + . is overflow : + INT VAR exponent pos := pos (number text, "E"); + IF exponent pos = 0 THEN exponent pos := pos (number text, "e") FI; + IF exponent pos = 0 + THEN TRUE + ELSE (number text SUB (exponent pos + 1)) <> "-" + FI + +END PROC next real; + + +TEXT PROC next text (TEXT CONST data, INT VAR data pos): + + INT CONST len :: int value (data, data pos); + data pos INCR len; + subtext (data, data pos-len, data pos-1) + +END PROC next text; + + +INT PROC int value (TEXT CONST data, INT VAR data pos): + + data pos INCR 2; + subtext (data, data pos-2, data pos-1) ISUB 1 + +END PROC int value; + + +PROC data line (INT CONST line no): + + data text CAT stat char; + data text CAT mki (line no) + +END PROC data line; + + +PROC data (TEXT CONST string, DTYPE VAR data type) : + + data text CAT data + mki (length (string)); + data text CAT string; + + . data : + IF data type = void type + THEN data char + ELIF data type = text type + THEN text char + ELSE errorstop (1051, "Unbekannter DTYPE: " + dump (data type)); "" + FI + +END PROC data; + + +PROC read (TEXT CONST data, INT VAR data pos, INT VAR i): + + type := code (data SUB data pos); + data pos INCR 1; + IF data pos >= LENGTH data + THEN errorstop (1004, "Keine Daten mehr für READ") + ELIF type = data code + THEN i := next int (data, data pos) + ELIF type = stat code + THEN data pos INCR 2; + read (data, data pos, i) + ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein INT") + FI; + +END PROC read; + + +PROC read (TEXT CONST data, INT VAR data pos, REAL VAR r): + + type := code (data SUB data pos); + data pos INCR 1; + IF data pos >= LENGTH data + THEN errorstop (1004, "Keine Daten mehr für READ") + ELIF type = data code + THEN r := next real (data, data pos) + ELIF type = stat code + THEN data pos INCR 2; + read (data, data pos, r) + ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein REAL") + FI; + +END PROC read; + + +PROC read (TEXT CONST data, INT VAR data pos, TEXT VAR t): + + type := code (data SUB data pos); + data pos INCR 1; + IF data pos >= LENGTH data + THEN errorstop (1004, "Keine Daten mehr für READ") + ELIF type = data code OR type = text code + THEN t := next text (data, data pos) + ELIF type = stat code + THEN data pos INCR 2; + read (data, data pos, t) + ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein TEXT") + FI; + +END PROC read; + + +TEXT PROC data string (TEXT CONST data, INT VAR data pos): + + IF type = text code + THEN """" + next text (data, data pos) + """" + ELSE "unbekannter DTYPE: " + text (type) + FI + +END PROC data string; + +END PACKET basic data handling; + + +PACKET basic odds and ends DEFINES trace, (* Autor: Heiko Indenbirken *) + start basic, (* Stand: 26.10.1987/rr/mo *) + end basic, + loop end, + basic stop: + +(* Fehlerbehandlung *) + +PROC trace (INT CONST stat no): + basic out ("[" + text (stat no) + "]") + +END PROC trace; + +(*Laufzeitprozeduren *) +PROC start basic: + set line nr (0); + initialize random (0.1); (* F26/rr *) + init output; + init input + +END PROC start basic; + +PROC end basic: + IF is error + THEN switch back to old sysout state + FI . + +END PROC end basic; + +(* Schleifenüberprüfung *) +BOOL PROC loop end (REAL CONST x, max, step) : + IF step > 0.0 + THEN x > max + ELSE x < max FI + +END PROC loop end; + +BOOL PROC loop end (INT CONST x, max, step) : + IF step > 0 + THEN x > max + ELSE x < max FI + +END PROC loop end; + +PROC basic stop (INT CONST stat no): + basic out ("STOP beendet das Programm in Zeile " + text (stat no)); + next line + +END PROC basic stop; + +END PACKET basic odds and ends + diff --git a/lang/basic/1.8.7/src/BASIC.Compiler b/lang/basic/1.8.7/src/BASIC.Compiler new file mode 100644 index 0000000..d4e4c21 --- /dev/null +++ b/lang/basic/1.8.7/src/BASIC.Compiler @@ -0,0 +1,2305 @@ +(***************************************************************************) +(* *) +(* Dritte von drei Dateien des EUMEL-BASIC-Systems *) +(* *) +(* Autor: Heiko Indenbirken *) +(* Überarbeitet von: Rudolf Ruland und Michael Overdick *) +(* *) +(* Stand: 27.10.1987 *) +(* *) +(***************************************************************************) + +PACKET basic compiler DEFINES basic, (* Autor: Heiko Indenbirken *) + basic version: (* Stand: 27.10.1987/rr/mo *) + +PROC basic version : + +putline (""13" "15" BASIC - Compiler Version 1.1 (27.10.1987) "14""); + +END PROC basic version; + +LET compiler msg = " ******* ENDE DER UEBERSETZUNG *******", + compiler err msg = " Fehler entdeckt"; + +LET (* S y m b o l T y p e n *) + any = 0, const = 1, var = 2, array = 3, denoter = 5, + res word= 8, operator= 9, eos = 10, del =11, stat no = 12, + result const = 13, (* F3/rr *) + user fn = 20; (* DEF/mo *) + +LET (* S y m b o l z e i c h e n *) + plus = 43, minus = 45, mult = 42, + div = 47, backslash = 92, exponent = 94, + equal = 61, semicolon = 59, comma = 44, + numbersign = 35, open bracket = 40, close bracket = 41, + eol = 13, eop = 14, mod op = 249; + +LET (* Reservierte Worte *) + as s = 129, base s = 132, call s = 133, chain s = 135, + clear s = 138, close s = 139, common s = 140, data s = 144, + def s = 145, defdbl s = 146, defint s = 147, defsng s = 148, + defstr s = 149, dim s = 150, else s = 151, end s = 152, + eof s = 153, error s = 156, field s = 158, for s = 160, + get s = 162, gosub s = 164, goto s = 165, if s = 167, (* F2/rr *) + input s = 169, kill s = 173, let s = 176, line in s = 177, + lprint s = 180, lset s = 181, mid s = 182, name s = 185, + next s = 186, on s = 188, open s = 189, option s = 190, + print s = 193, put s = 194, rand s = 195, read s = 196, + rem s = 197, restore s = 198, resume s = 199, return s = 200, + rset s = 203, step s = 209, stop s = 210, swap s = 213, + tab s = 214, then s = 216, to s = 217, troff s = 218, + tron s = 219, using s = 220, wait s = 222, wend s = 223, + while s = 224, width s = 225, write s = 226, not = 250, + cls s = 227, usr = 234, sub = 235; (* mo *) + +LET nil = "", + intern error = 51; + +LET SYMBOL = STRUCT (TEXT name, INT no, type, ADDRESS adr, DTYPE data); +ADDRESS CONST niladr :: LOC -4; +SYMBOL CONST nilsymbol :: SYMBOL : (nil, any, any, nil adr, void type); +SYMBOL VAR symb; +BOOL VAR found; +OPN VAR opn; + +TEXT OP NAME (SYMBOL CONST val): + IF val.type = const + THEN constant value + ELIF val.type = stat no + THEN text (val.no) + ELSE val.name FI . + +constant value: + IF val.data = int type AND length (val.name) = 2 + THEN text (val.name ISUB 1) + ELIF val.data = real type AND length (val.name) = 8 + THEN text (val.name RSUB 1) + ELSE val.name FI . + +END OP NAME; + +PROC careful error (INT CONST no, TEXT CONST name, addition): (* DEF/mo *) + IF at end of statement + THEN basic error (no, name, addition) + ELSE basic error without leaving statement + FI. + +at end of statement: + symb.type = eos. + +basic error without leaving statement: + basic error (no, name, addition, FALSE); + error no INCR 1. + +END PROC careful error; + +(* P r e c o m p i l e r *) +PROC next symbol: + symb.adr := niladr; + next symbol (symb.name, symb.no, symb.type, symb.data); + + IF symb.no = end symbol AND symb.type = res word + THEN symb.no := -symb.no; + symb.type := eos; + FI +END PROC next symbol; + +PROC skip (INT CONST symbol, type): + IF symb.type = type AND symb.no = symbol + THEN next symbol + ELSE basic error (2, NAME symb, name of (symbol) + " erwartet") FI . +END PROC skip; + +PROC get letter (SYMBOL VAR symbol): + IF symb.type = var AND (LENGTH symb.name) = 1 + THEN symbol := symb; + next symbol + ELSE basic error (2, NAME symb, "Buchstabe erwartet, " + type of (symb.type) + " gefunden") FI . + +END PROC get letter; + +PROC get var (SYMBOL VAR symbol): + IF symb.type = var + THEN variable (symbol) + ELIF symb.type = array + THEN array var (symbol) + ELSE basic error (2, NAME symb, "Variable erwartet, " + type of (symb.type) + " gefunden") FI . + +END PROC get var; + +PROC get expr (SYMBOL VAR symbol): + get expression (symbol, 0) +END PROC get expr; + +PROC get const (SYMBOL VAR symbol, DTYPE CONST data): + IF symb.type = const + THEN symbol := symb; + declare const (symbol, data); (* F3/rr *) + next symbol + ELSE basic error (2, NAME symb, "Konstante erwartet, " + type of (symb.type) + " gefunden") FI . + +END PROC get const; + +PROC get var (SYMBOL VAR symbol, DTYPE CONST data): + get var (symbol); + convert (symbol, data) +END PROC get var; + +PROC get expr (SYMBOL VAR symbol, DTYPE CONST data): + get expression (symbol, 0); + convert (symbol, data) +END PROC get expr; + +PROC get expression (SYMBOL VAR result, INT CONST last prio): + get single result; + WHILE symb.type = operator AND higher priority + REP get dyadic operand; + gen dyadic operation + PER . + +get single result: + INT VAR prio; + SELECT symb.type OF + CASE var: variable (result) + CASE array: array var (result) + CASE const: get const + CASE operator: get monadic operator + CASE res word: basic function (result) + CASE user fn: user function (result) (* DEF/mo *) + OTHERWISE get bracket END SELECT . + +get const: + result := symb; + declare const (result, result. data); (* F3/rr *) + next symbol . + +get monadic operator: + get operator; + prio := monadic op prio; (* mo *) + get monadic operand; + generate monadic operator . + +monadic op prio: (* mo *) + IF op no = not + THEN 6 + ELSE 12 + FI. + +get monadic operand: + SYMBOL VAR operand; + next symbol; + get expression (operand, prio). + +generate monadic operator: +(* Mögliche Ops: +, - und NOT *) + parameter (1, operand.data, const, operand.adr); + parameter (2, operand.data, var, next local adr (operand.data)); + parameter (3, void type, const, nil adr); + + IF op no = plus + THEN result := operand + ELIF op no = minus + THEN generate minus op + ELIF op no = not + THEN generate not op + ELSE basic error (2, op name, "Kein monadischer Operator") FI . + +generate minus op: + IF operand.data = int type + THEN apply (1, 2, int minus) + ELIF operand.data = real type + THEN apply (1, 2, real minus) + ELSE basic error (82, op name, NAME operand + " : " + dump (operand.data)) FI; + result := SYMBOL:(op name, 0, result const, local adr, operand.data) . + +generate not op: + IF operand.data = int type + THEN apply (1, 1, int not opn) + ELIF operand.data = real type + THEN apply (1, 1, real not opn) + ELSE basic error (82, op name, NAME operand + " : " + dump (operand.data)) FI; + result := SYMBOL:(op name, 0, result const, local adr, operand.data) . + +get operator: + INT CONST op no :: symb.no; + TEXT CONST op name :: symb.name . + +higher priority: + get operator; + prio := dyadic op prio; + prio > last prio . + +dyadic op prio: + IF is bool op (op no) THEN bool op prio + ELIF op no = plus OR op no = minus THEN 8 + ELIF op no = mod op THEN 9 + ELIF op no = backslash THEN 10 + ELIF op no = mult OR op no = div THEN 11 + ELIF op no = exponent THEN 13 + ELSE (* relational operator *) 7 + FI. + +bool op prio: + 256 - op no. + +get bracket: + IF symb.type = del AND symb.no = open bracket + THEN next symbol + ELSE basic error (22, NAME symb, "") FI; + get expression (result, 0); + skip (close bracket, del) . + +get dyadic operand: + next symbol; + get expression (operand, prio) . + +gen dyadic operation: + convert operands; + identify dyadic operator; + generate dyadic operator . + +convert operands: + DTYPE CONST op type :: type of operation; + convert (result, op type); + convert (operand, op type) . + +type of operation: + IF is bool op (op no) + THEN int type + ELIF result.data = operand.data + THEN result.data + ELSE real type FI . + +identify dyadic operator: + BOOL VAR local found; + OPN VAR local opn; + DTYPE VAR data; + parameter (1, result.data, const, result.adr); + parameter (2, operand.data, const, operand.adr); + identify (op no, 1, 2, local opn, local found); + IF NOT local found + THEN basic error (83, symbol of (op no), + NAME result + " : " + dump (result.data) + " und " + + NAME operand + " : " + dump (operand.data)) + ELSE data := dtype (3) FI . + +generate dyadic operator: + declare (3, var); + define (3, next local adr (data)); + apply (3, push); + apply (1, 2, local opn); + result := SYMBOL:(op name, 0, result const, local adr, data) . + +END PROC get expression; + +PROC variable (SYMBOL VAR symbol): + symbol := symb; + next symbol; + IF known (symbol.no) + THEN get adr from table + ELSE declare var (symbol, nil) FI . + +get adr from table: + TEXT VAR defined dim; + remember (symbol.no, symbol.type, symbol.adr, symbol.data, defined dim) . + +END PROC variable; + +PROC array var (SYMBOL VAR symbol field): +(* Aufbau der Dimensionsangaben in der Symboltabelle *) +(* limit 1 [limit 2]... Basis Elemente *) +(* jeweils als 2 Byte Integer/Text *) +(* Die Dimension ist dann DIM/2-2 *) + ROW 100 SYMBOL VAR indizes; + TEXT VAR limits; + INT VAR dim; + + symbol field := symb; next symbol; + get paramfield (indizes, dim, int type); + + IF known (symbol field.no) + THEN check field dim and data + ELSE declare new field FI; + generate field index . + +check field dim and data: + INT VAR type; + DTYPE VAR data; + remember (symbol field.no, type, symbol field.adr, data, limits); + + IF old dim <> dim + THEN basic error (84, symbol field.name, "Dimensioniert in " + text (old dim) + " Dimensionen, gefundene Anzahl Indizes: " + text (dim)) + ELIF NOT (symbol field.data = data) + THEN basic error (intern error, symbol field.name, dump (data) + " <=> " + dump (symbol field.data)) + ELIF NOT (symbol field.type = type) + THEN basic error (intern error, symbol field.name, "Feld erwartet, " + type of (type) + " gefunden") FI . + +old dim: (length (limits) DIV 2) - 2 . + +declare new field: + limits := dim * ""10""0"" + mki (array base) + + mki ((10 - array base + 1)**dim); + declare var (symbol field, limits) . + +generate field index: + init field subscription; + FOR j FROM 1 UPTO dim + REP increase field index; + calc index length and limit; + calculate field pointer; + symbol field.adr := REF pointer + PER . + +init field subscription: + ADDRESS VAR pointer :: next local adr (row type), + index adr :: next local adr (int type); + INT VAR j, elem length :: (limits ISUB (dim+2)) * typesize (symbol field.data), + elem limit, + elem offset :: 1 - (limits ISUB (dim+1)); + BOOL CONST base zero := elem offset = 1 . + +increase field index: + IF base zero + THEN parameter (1, int type, const, index.adr); + parameter (2, int type, const, one value); + parameter (3, int type, var, index adr); + parameter (4, void type, const, nil adr); + apply (1, 3, int add); + ELSE index adr := index.adr FI . + +index: indizes [j] . + +calc index length and limit: + elem limit := (limits ISUB j) + elem offset; + elem length := elem length DIV elem limit . + +calculate field pointer: + parameter (1, int type, const, symbol field.adr); + parameter (2, int type, const, index adr); + parameter (3, int type, elem length); + parameter (4, int type, elem limit); + parameter (5, int type, const, pointer); + parameter (6, void type, const, nil adr); + apply (1, 5, subscript); + +END PROC array var; + +PROC get paramfield (ROW 100 SYMBOL VAR params list, INT VAR no): + skip (open bracket, del); + FOR no FROM 1 UPTO 100 + REP get expression (params list [no], 0); + IF symb.type = del AND symb.no = close bracket + THEN next symbol; + LEAVE get paramfield + ELSE skip (comma, del) FI + PER . + +END PROC get paramfield; + +PROC get paramfield (ROW 100 SYMBOL VAR params list, INT VAR no, DTYPE CONST data): + skip (open bracket, del); + FOR no FROM 1 UPTO 100 + REP get expression (params list [no], 0); + convert (params list [no], data); + IF symb.type = del AND symb.no = close bracket + THEN next symbol; + LEAVE get paramfield + ELSE skip (comma, del) FI + PER . + +END PROC get paramfield; + +PROC examine access rights (ROW 100 SYMBOL VAR params list, INT CONST no): + + INT VAR j; + FOR j FROM 1 UPTO no REP + IF params list [j].type = const OR params list [j].type = result const + THEN IF access (j) = 2 + THEN basic error (103, NAME params list [j], "im " + text (j) + + ". Eintrag der Parameterliste") + FI + FI + PER + +END PROC examine access rights; + +PROC basic function (SYMBOL VAR ftn): (* Änd. 11.08.87, mo *) + init and check function; + IF symb.type = del AND symb.no = open bracket + THEN get paramfield (params list, number params); + FI; + apply function . + +init and check function: + ROW 100 SYMBOL VAR params list; + INT VAR number params :: 0; + BOOL CONST is usr :: symb.no = usr; + IF is usr + THEN check proc name + FI; + ftn := symb; + next symbol . + +check proc name: + next symbol; + IF symb.type = array + THEN symb.name := subtext (symb.name, 1, LENGTH symb.name-2) + ELIF symb.type <> var + THEN basic error (2, NAME symb, "Prozedurname erwartet") + FI. + +apply function: + OPN VAR ftn local opn; + BOOL VAR ftn found; + INT CONST result :: number params+1; + + INT VAR j; + FOR j FROM 1 UPTO number params + REP parameter (j, params list [j].data, const, params list [j].adr) PER; + IF is usr + THEN identify proc; + examine access rights (params list, number params); + ELSE identify function + FI; + + ftn.adr := next local adr (ftn.data); + + declare (result, var); + define (result, ftn.adr); + apply (result, push); + apply (1, number params, ftn local opn). + +identify proc: + identify (deshift (ftn.name), 1, number params, ftn local opn, ftn found); + ftn.data := dtype (result); + IF NOT ftn found + THEN basic error (99, ftn.name, "Parameter angegeben: " + param list (1, number params)) + ELIF ftn.data = void type + THEN basic error (5, ftn.name, "Die Prozedur liefert keinen Wert") + ELIF NOT (ftn.data = int type) AND NOT (ftn.data = real type) AND NOT (ftn.data = text type) + THEN basic error (5, ftn.name, "Der Typ des Resultats ist nicht erlaubt, gefunden: " + + dump (dtype (result))) + FI. + +identify function: + identify (ftn.no, 1, number params, ftn local opn, ftn found); + IF ftn found + THEN ftn.data := dtype (result) + ELIF is basic function (ftn.no) + THEN basic error (98, ftn.name, "Argument(e) angegeben: " + param list (1, number params)) + ELSE basic error (22, ftn.name, "Anweisung(sbestandteil) gefunden") + FI. + +END PROC basic function; + +PROC user function (SYMBOL VAR result): (* DEF/mo *) + check if function defined; + get arguments if expected; + gosub (user function label); + copy result. + +check if function defined: + TEXT CONST scope :: name of (symb.no) + "?"; + IF NOT known (symb.no) + THEN basic error (18, symb.name, "") + ELIF scanner scope = scope + THEN basic error (85, symb.name, "") + FI. + +get arguments if expected: + INT VAR param counter; + TEXT VAR dim text; + result := symb; + remember (symb.no, symb.type, result.adr, result.data, dim text); + INT VAR number of params :: LENGTH dim text DIV 2 - 1; + next symbol; + IF number of params > 0 + THEN get all arguments + ELIF symb.no = open bracket AND symb.type = del + THEN basic error (5, symb.name, "Kein Argument erwartet") + FI. + +get all arguments: + IF symb.no <> open bracket OR symb.type <> del + THEN basic error (5, NAME symb, text (number of params) + " Argument(e) erwartet") + FI; + next symbol; + FOR param counter FROM 2 UPTO number of params REP + get one argument; + skip comma; + PER; + get one argument; + skip close bracket. + +get one argument: + SYMBOL VAR ftn param; + ftn param.no := dim text ISUB param counter; + remember (ftn param.no, ftn param.type, ftn param.adr, ftn param.data, ftn param.name); + IF ftn param.type <> var + THEN basic error (intern error, name of (ftn param.no), "Parametereintrag fehlerhaft") + FI; + SYMBOL VAR expr res; + get expr (expr res, ftn param.data); + apply move (ftn param.adr, expr res.adr, ftn param.data). + +skip comma: + IF symb.no = close bracket AND symb.type = del + THEN basic error (5, symb.name, text (number of params) + " Argumente erwartet") + ELIF symb.no <> comma OR symb.type <> del + THEN basic error (2, NAME symb, " , in Argumentenliste erwartet") + FI; + next symbol. + +skip close bracket: + IF symb.no = comma AND symb.type = del + THEN basic error (5, symb.name, "Nur " + text (number of params) + " Argument(e) erwartet") + ELIF symb.no <> close bracket OR symb.type <> del + THEN basic error (2, NAME symb, " ) nach Argumentenliste erwartet") + FI; + next symbol. + +user function label: + label list [dim text ISUB 1]. + +copy result : + apply move (next local adr (result.data), result.adr, result.data); + result.adr := local adr. + +END PROC user function; + +PROC apply move (ADDRESS CONST dest adr, source adr, DTYPE CONST datype): + parameter (1, datype, var, dest adr); + parameter (2, datype, const, source adr); + parameter (3, void type, const, nil adr); + + IF datype = int type + THEN apply (1, 2, int move) + ELIF datype = real type + THEN apply (1, 2, real move) + ELIF datype = text type + THEN apply (1, 2, text move) + ELSE basic error (2, "=", "Unbekannter Datentyp: " + dump (datype)) FI . + +END PROC apply move; + +PROC convert (SYMBOL VAR symbol, DTYPE CONST to data): (* F3/rr *) + IF to data = from data + THEN + ELIF symbol.type = const + THEN declare const (symbol, to data) + ELIF to data = int type + THEN make int + ELIF to data = real type + THEN make real + ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI . + +from data : symbol.data . + +make real : + IF symbol.data = int type + THEN parameter (1, symbol.data, const, symbol.adr); + parameter (2, real type, var, next local adr (real type)); + parameter (3, void type, const, nil adr); + apply (1, 1, int to real); + symbol.adr := local adr; + symbol.data := real type + ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI . + +make int : + IF symbol.data = real type + THEN parameter (1, symbol.data, const, symbol.adr); + parameter (2, int type, var, next local adr (int type)); + parameter (3, void type, const, nil adr); + apply (1, 1, real to int); + symbol.adr := local adr; + symbol.data := int type + ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI . + +END PROC convert; + +PROC declare const (SYMBOL VAR symbol constant, DTYPE CONST data): + convert symb value; + IF new constant + THEN declare this constant + ELSE get table entry FI . + +convert symb value: + IF data = symbol constant.data + THEN LEAVE convert symb value + ELIF data = int type AND symbol constant.data = real type + THEN symbol constant.name := mki (symbol constant.name RSUB 1); + ELIF data = real type AND symbol constant.data = int type + THEN symbol constant.name := mkd (symbol constant.name ISUB 1); + ELIF data = text type AND symbol constant.data = int type + THEN symbol constant.name := text (symbol constant.name ISUB 1) + ELIF data = text type AND symbol constant.data = real type + THEN symbol constant.name := text (symbol constant.name RSUB 1) + ELSE basic error (13, NAME symbol constant, dump (data) + " erwartet, " + + dump (symbol constant.data) + " gefunden") FI; + symbol constant.data := data . + +new constant: +(* Konstanten werden wie folgt abgelegt: *) +(* INT: § HL *) +(* REAL: § MMMMMMME *) +(* TEXT: § Text *) + put name ("§ " + symbol constant.name, symbol constant.no); + NOT known (symbol constant.no) . + +declare this constant: + IF data = int type + THEN allocate denoter (symbol constant.adr, symbol constant.name ISUB 1) + ELIF data = real type + THEN allocate denoter (symbol constant.adr, symbol constant.name RSUB 1) + ELIF data = text type + THEN allocate denoter (symbol constant.adr, symbol constant.name) FI; + recognize (symbol constant.no, const, symbol constant.adr, data, nil) . + +get table entry: + INT VAR table type; + TEXT VAR table dim; + remember (symbol constant.no, table type, symbol constant.adr, symbol constant.data, table dim); + IF table dim <> nil + THEN basic error (intern error, NAME symbol constant, "Dimension in Tabelle ungleich niltext") + ELIF NOT (symbol constant.data = data) + THEN basic error (intern error, NAME symbol constant, "Falscher DTYPE in Tabelle, erw: " + dump (data) + + ", gef: " + dump (symbol constant.data)) FI . + +END PROC declare const; + +PROC declare var (SYMBOL VAR symbol var, TEXT CONST dim): (* F4/rr *) + allocate variable; + recognize (symbol var.no, symbol var.type, symbol var.adr, symbol var.data, dim) . + +allocate variable : + symbol var.adr := next local adr (symbol var.data); + IF dim <> nil + THEN INT VAR index; + ADDRESS VAR dummy; + FOR index FROM 2 UPTO no of elements + REP dummy := next local adr (symbol var.data) PER; + FI . + +no of elements: + (dim ISUB (LENGTH dim DIV 2)) . +END PROC declare var; + +PROC parameter (INT CONST p, DTYPE CONST d type, INT CONST value): + declare (p, d type); + declare (p, denoter); + define (p, value); +END PROC parameter; + +PROC apply (INT CONST first, number params, TEXT CONST name): + identify (name, first, number params, opn, found); + IF NOT found + THEN errorstop (1051, "PROC " + name + ", Parameter: " + param list (first, number params) + ", nicht gefunden!") FI; + apply (first, number params, opn) + +END PROC apply; + +PROC clear local stack : (* F4/rr *) + + define local variables; + clear index; + define (rep); index incr one; + if local storage less or equal index then goto end; + get cell address; + clear cell; + apply (rep); + define (end); + clear cell address; + + . define local variables : + LABEL VAR rep, end; + ADDRESS VAR index; + declare (rep); declare (end); + allocate variable (index, type size (int type)); + + . clear index : + parameter (1, int type, var, index); + apply (1, 1, clear); + + . index incr one : + parameter (1, int type, var, index); + apply (1, 1, incone); + + . if local storage less or equal index then goto end : + parameter (1, int type, const, loc storage); + parameter (2, int type, const, index); + apply (1, 2, lsequ); + apply (end, TRUE); + + . get cell address : + parameter (1, int type, const, LOC 2); + parameter (2, int type, const, index); + parameter (3, int type, 1); + parameter (4, int type, 16000); + parameter (5, int type, const, LOC 0); + apply (1, 5, subscript); + + . clear cell : + parameter (1, int type, var, REF LOC 0); + apply (1, 1, clear); + + . clear cell address : + parameter (1, int type, var, LOC 0); + apply (1, 1, clear); + parameter (1, int type, var, LOC 1); + apply (1, 1, clear); + +END PROC clear local stack; + +(* M a i n *) +(* ̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃ *) +(* C o m p i l e r *) +(* ***** G l o b a l e V a r i a b l en ***** *) +INT VAR end symbol :: 0, error no :: 0, act stat no :: 0, array base :: 0; +BOOL VAR basic trace, was warning; +ADDRESS VAR data pos, data text; + + +(* Globale Operationen *) +OPN VAR basic init, basic frame, basic module, ret, equal op, + int minus, real minus, int not opn, real not opn, + trace op, ln op, push, + int incr, real incr, int add, + int move, real move, text move, test, + real to int, int to real, subscript, + clear, incone, lsequ, (* F4/rr *) + basic out text; + +(* Parameter VOID *) + init ("RTN", 1, 0, ret); + +(* Parameter INT *) + declare (1, int type); + init ("intnot", 1, 1, int not opn); (* mo *) + init ("PP", 1, 1, push); + init ("LN", 1, 1, ln op); + init ("real", 1, 1, int to real); + init ("TEST", 1, 1, test); + init ("CLEAR", 1, 1, clear); + init ("INCONE", 1, 1, incone); + init ("trace", 1, 1, trace op); + +(* Parameter INT INT *) + declare (2, int type); + init ("COMPLINT", 1, 2, int minus); + init ("MOVE", 1, 2, int move); + init ("INC", 1, 2, int incr); + init ("EQU", 1, 2, equal op); + init ("LSEQU", 1, 2, lsequ); + +(* Parameter INT INT INT *) + declare (3, int type); + init ("ADD", 1, 3, int add); + +(* Paramter REAL *) + declare (1, real type); + init ("realnot", 1, 1, real not opn); (* mo *) + init ("cint", 1, 1, real to int); + +(* Parameter REAL REAL *) + declare (2, real type); + init ("COMPLREAL", 1, 2, real minus); + init ("FMOVE", 1, 2, real move); + init ("INCR", 1, 2, real incr); + +(* Parameter TEXT *) + declare (1, text type); + init ("basicout", 1, 1, basic out text); + +(* Paramter TEXT TEXT *) + declare (2, text type); + init ("TMOVE", 1, 2, text move); + +(* Parameter ADDRESS INT DENOTER DENOTER ADDRESS *) + declare (3, denoter); + declare (4, denoter); + init ("SUBSCRIPT", 1, 5, subscript); + +PROC init (TEXT CONST name, INT CONST local from, number params, OPN VAR local opn): + identify (name, local from, number params, local opn, found); + IF NOT found + THEN errorstop (1051, "PROC init (TC, IC, IC, OPN VAR): OPN für """ + name + """ nicht gefunden") FI +END PROC init; + +(* Runtime Konstanten *) + ADDRESS VAR true value, false value, niltext value, + zero value, one value, two value, three value, + comma value, int one value, real one value, + loc storage; (* F4/rr *) + +(* +++++ Globale Variablen +++++ *) + BOOL VAR proc found; + INT VAR deftype, field elems, i, params; + ROW 100 SYMBOL VAR param; + SYMBOL VAR base size, begin range, end range, expr result, field, filename, + from, len, image, label, old name, new name, + question, size, tab pos, var result; + TEXT VAR constant, field size, proc name; + +(* Label-Verwaltung *) +LET label list size = 4100; +BOUND ROW label list size LABEL VAR label list; +DATASPACE VAR label ds; +INITFLAG VAR label init :: FALSE; +INT VAR last label no; + +(* ***** I n t e r f a c e P r o z d u r e n ***** *) +PROC basic: + basic (last param) +END PROC basic; + +PROC basic (TEXT CONST basic file name): + basic (basic file name, nil) +END PROC basic; + +PROC basic (TEXT CONST basic file name, prog name): + IF NOT exists (basic file name) + THEN errorstop ("""" + basic file name + """ gibt es nicht") + ELSE FILE VAR basic file :: sequential file (modify, basic file name); (* F5/rr *) + headline (basic file, basic file name); + last param (basic file name); + basic (basic file, prog name) + FI; + +END PROC basic; + +PROC basic (FILE VAR source file, TEXT CONST prog name): + IF prog name <> nil CAND prog name is not a tag (* F5/rr *) + THEN errorstop ("unzulässiger Programmname : """ + prog name + """"); + FI; + modify (source file); (* F5/rr *) + disable stop; + init label table; + store status; + coder on (data allocation by coder); + compile (source file, progname); + restore status; + start basic prog . + +prog name is not a tag : (* F5/rr *) + LET tag = 1; + INT VAR symbol type; + TEXT VAR symbol name; + scan (prog name); + next symbol (symbol name, symbol type); + symbol name <> prog name OR symbol type <> tag . + +init label table: + IF NOT initialized (label init) + THEN label ds := nilspace; + label list := label ds; + FI . + +store status: + INT CONST source line :: line no (source file), + source col :: col (source file); + BOOL CONST check status :: check; + check on . + +restore status: + to line (source file, source line); + col (source file, source col); + IF NOT check status + THEN check off FI . + +start basic prog: + IF error no > 0 OR is error + THEN basic error end + ELSE normal end + FI; + close (source file) . + +basic error end: + coder off (FALSE, FALSE, nop); + IF is error + THEN put error; + clear error + ELSE display (""13""10""10""); (* F20/rr *) + display (text (error no) + compiler err msg); + display (""13""10""10""); + display (compiler msg); + display (""13""10""); + IF sysout <> "" + THEN line (2); + put (text (error no) + compiler err msg); + line (2); + put (compiler msg); + line + FI + FI; + show file and error . + +show file and error: (* F20/rr *) + IF anything noted CAND command dialogue + THEN noteedit (source file); + FI; + errorstop (nil) . + +normal end: + IF prog name = nil + THEN run basic proc + ELSE insert basic proc FI; + IF warnings AND was warning + THEN show file and error + FI. + +run basic proc: + coder off (FALSE, TRUE, basic frame); + display (""13""10"") . + +insert basic proc: + coder off (TRUE, TRUE, basic frame); + coder on (data allocation by coder); + coder off (FALSE, FALSE, basic init); + display (""13""10"") . + +END PROC basic; + +PROC compile (FILE VAR source file, TEXT CONST progname): + enable stop; + init compiler; + init basic prog; + + begin scanning (source file); + next symbol; + get statement group (eop); + end compiling . + +init compiler: + end symbol := 0; + error no := 0; + act stat no := 0; + array base := 0; + basic trace := FALSE; + was warning := FALSE; + + init storage; + init label; + init data; + init table . + +init label: + TEXT VAR local stat no; + INT VAR stat nos; + init stat no (source file, error no); (* F21/rr *) + IF error no > 0 THEN LEAVE compile FI; + all stat no (local stat no, stat nos); + FOR i FROM 1 UPTO stat nos + REP declare (label list [i]) PER; + last label no := stat nos. (* DEF/mo *) + +init basic prog: + LIB VAR packet; + declare (basic packet name, packet); + define (packet); + parameter (1, void type, const, nil adr); + declare (basic init); + IF progname = nil + THEN declare (basic frame) + ELSE declare (progname, 1, 0, basic frame) FI; + declare (basic module); + declare runtime const; + declare basic init; + declare basic frame; + declare basic module . + +basic packet name: + IF progname <> "" + THEN "BASIC." + progname + ELSE "BASIC" + FI. + +declare runtime const: + allocate variable (data text, type size (text type)); + allocate variable (data pos, type size (int type)); + allocate variable (loc storage, type size (int type)); (* F4/rr *) + + allocate denoter (true value, 0); + allocate denoter (false value, -1); + allocate denoter (niltext value, nil); + allocate denoter (one value, 1); + allocate denoter (two value, 2); + allocate denoter (three value, 3); + allocate denoter (real one value, 1.0); + allocate denoter (comma value, ","); + + zero value := true value; + int one value := one value . + +declare basic init: + begin module; + define (basic init, 4); + parameter (1, text type, var, data text); + parameter (2, int type, var, data pos); + apply (1, 2, "initdata"); + parameter (1, void type, const, nil adr); + apply (1, 0, ret); + end module . + +declare basic frame: + begin module; + define (basic frame, 4); + + IF prog name = nil + THEN parameter (1, void type, const, nil adr); + apply (1, 0, basic init); + FI; + + declare (1, int type); + declare (1, const); + define (1, 0); + parameter (2, void type, const, nil adr); + apply (1, 1, ln op); + + apply (1, 0, "disablestop"); + apply (1, 0, "startbasic"); + + parameter (1, int type, var, data pos); + parameter (2, int type, const, one value); + parameter (3, void type, const, nil adr); + apply (1, 2, int move); + + parameter (1, void type, const, nil adr); + apply (1, 0, basic module); + apply (1, 0, "endbasic"); + parameter (1, void type, const, nil adr); + apply (1, 0, ret); + end module . + +declare basic module: + LABEL VAR start lab; + begin module; + define (basic module); + declare (start lab); + apply (1, 0, "enablestop"); + gosub (start lab); + parameter (1, void type, const, nil adr); + apply (1, 0, "returnerror"); (* mo *) + define (start lab); + clear local stack . (* F4/rr *) + +end compiling: + parameter (1, void type, const, nil adr); + apply (1, 0, ret); + define (loc storage, local storage - 1); (* F4/rr *) + set length of local storage (basic module, max (2, local storage)); (* F4/rr *) + IF error no = 0 + THEN end module FI . + +END PROC compile; + +PROC get statement group (INT CONST new symbol): +(* 'get statement group' compiliert das ganze Programm bis zum Auftreten *) +(* von 'end symbol' *) + disable stop; + new end symbol; + get all basic lines; + old end symbol . + +new end symbol: + INT CONST old symbol :: end symbol; + end symbol := new symbol . + +old end symbol: + end symbol := old symbol . + +get all basic lines: + REP get basic line; + + IF is error + THEN error handling + ELIF symb.type = eos + THEN check this eos FI + PER . + +error handling: (* F20/rr *) + IF error in basic program + THEN error no INCR 1 + ELIF end of source file + THEN clear error; + LEAVE get all basic lines + ELIF halt from terminal + THEN LEAVE get statement group + ELSE error no INCR 1; + handle internal error; + LEAVE get statement group + FI; + clear error; + scope compulsory (TRUE); (* DEF/mo *) + set scope (""); (* DEF/mo *) + next statement; + next symbol . + +error in basic program: + errorcode = 101. + +end of source file: + errorcode = 99. + +halt from terminal: + errorcode = 1. + +handle internal error : (* F20/rr *) + TEXT VAR error :: "BASIC-Compiler ERROR"; + IF errorcode <> 0 + THEN error CAT " #" + text (errorcode) FI; + IF errorline > 0 + THEN error CAT " at " + text (errorline) FI; + error CAT " : "; + error CAT errormessage; + IF sysout <> "" THEN putline (error) FI; + note (error); + noteline; + clear error; + errorstop (error). + +check this eos: + IF symb.no = eol + THEN next symbol + ELIF symb.no = -new symbol OR symb.no = eop + THEN LEAVE get all basic lines (* mo *) + ELSE basic error (intern error, NAME symb, "EOL erwartet, " + + type of (symb.type) + " gefunden") + FI . + +END PROC get statement group; + +PROC get basic line (INT CONST new symbol): +(*Die Abbruchbedingungen werden neu gesetzt und bei Verlassen der *) +(*Prozedur zurückgesetzt. *) + disable stop; + INT CONST old symbol :: end symbol; + end symbol := new symbol; + get basic line; + end symbol := old symbol . + +END PROC get basic line; + +PROC get basic line: +(* 'get basic line' behandelt genau eine Zeile mit Zeilennummer. *) + enable stop; + IF symb.type = stat no + THEN gen stat no (symb.no) FI; + + REP get one basic statement PER . + +get one basic statement: +(* 'get one basic statement' behandelt genau ein Statement. *) + IF symb.type = eos + THEN get end of statement + ELIF symb.type = res word OR symb.type = var OR symb.type = array + THEN get one statement + ELSE basic error (2, NAME symb, type of (symb.type) + " ohne Zusammenhang") FI . + +get end of statement: + IF symb.no = eos + THEN next symbol + ELSE LEAVE get basic line FI . + +get one statement: + IF symb.type = res word + THEN get res word statement + ELIF symb.type = var OR symb.type = array + THEN let statement + FI; + skip comma if else expected; + IF symb.type <> eos + THEN basic error (2, NAME symb, "EOS erwartet, " + type of (symb.type) + " gefunden") + FI. + +skip comma if else expected: + IF end symbol = else s AND symb.type = del AND symb.no = comma + THEN next symbol; + IF symb.type <> eos OR symb.no <> -else s + THEN basic error (2, NAME symb, "ELSE erwartet") + FI + FI. + +get res word statement: + SELECT symb.no OF + CASE as s : basic error (90, symb.name, "") + CASE base s : basic error (91, symb.name, "") + CASE call s, + chain s : call statement + CASE clear s : not implemented + CASE close s : not implemented + CASE cls s : cls statement (* mo *) + CASE common s : not implemented + CASE data s : data statement + CASE def s : def statement (* mo *) + CASE defint s, + defdbl s, + defsng s, + defstr s : def type statement + CASE dim s : dim statement + CASE else s : basic error (92, symb.name, "") + CASE end s : end statement + CASE error s : error statement + CASE field s : not implemented + CASE for s : for statement + CASE get s : not implemented + CASE gosub s : gosub statement + CASE goto s : goto statement + CASE if s : if statement + CASE input s : input statement + CASE kill s : kill statement + CASE let s : let statement + CASE line in s: line statement + CASE lprint s : lprint statement (* mo *) + CASE l set s : l set statement + CASE mid s : mid statement + CASE name s : name statement + CASE next s : basic error (1, symb.name, "") + CASE on s : on statement + CASE open s : not implemented + CASE option s : option statement + CASE print s : print statement + CASE put s : not implemented + CASE rand s : randomize statement + CASE read s : read statement + CASE rem s : rem statement + CASE restore s: restore statement + CASE resume s : not implemented + CASE return s : return statement + CASE r set s : r set statement + CASE step s : basic error (93, symb.name, "") + CASE stop s : stop statement + CASE sub : basic error (101, symb.name, "") + CASE swap s : swap statement + CASE tab s : basic error (94, symb.name, "") + CASE then s : basic error (95, symb.name, "") + CASE to s : basic error (96, symb.name, "") + CASE troff s : troff statement + CASE tron s : tron statement + CASE using s : basic error (97, symb.name, "") + CASE wait s : not implemented + CASE wend s : basic error (30, symb.name, "") + CASE while s : while statement + CASE width s : width statement + CASE write s : write statement + OTHERWISE basic error (104, symb.name, "") END SELECT. + +not implemented: + basic error (100, symb.name, ""). + +call statement: +(*CALL <proc name> [(<argument list>)] *) + next symbol; + get proc name; + get proc parameter; + apply proc . + +get proc name: + proc name := symb.name; + IF symb.type = array + THEN proc name := subtext (proc name, 1, LENGTH proc name-2) FI; + next symbol . + +get proc parameter: + params := 0; + IF symb.type = del AND symb.no = open bracket + THEN get paramfield (param, params) FI . + +apply proc: + OPN VAR proc opn; + FOR i FROM 1 UPTO params + REP parameter (i, param [i].data, const, param [i].adr) PER; + identify (deshift (proc name), 1, params, proc opn, proc found); + + IF NOT proc found + THEN basic error (99, proc name, "Parameter angegeben: " + param list (1, params)) + ELIF result found + THEN basic error (5, proc name, "Kein Resultat erlaubt (gefunden: " + dump (result data) + ")") + FI; + + examine access rights (param, params); + + parameter (params+1, void type, const, nil adr); + apply (1, params, proc opn) . + +result found: + NOT (result data = void type) . + +result data: + dtype (params+1) . + +cls statement: +(*CLS *) + next symbol; + apply (1, 0, "nextpage"). + +data statement: +(*DATA <list of constants> *) + DTYPE VAR const data; + data line (act stat no); + REP IF next data (constant, const data) + THEN data (constant, const data) + ELSE basic error (2, "EOL", "Daten fehlen !") FI; + + next symbol; + IF symb.type = eos + THEN LEAVE data statement + ELIF symb.type <> del OR symb.no <> comma + THEN basic error (2, NAME symb, " , erwartet") FI + PER . + +def statement: (* DEF/mo *) +(*DEF FN<name> [(parameter list)] = <function definition> *) + get function name; + store label of function; + get all params; + get function definition. + +get function name: + next symbol; + IF symb.type <> user fn + THEN treat wrong function name + ELIF LENGTH symb.name <= 2 + THEN basic error (2, symb.name, "Unerlaubter Funktionsname") + ELIF known (symb.no) + THEN basic warning ("Die Funktion """ + symb.name + """ wurde bereits definiert"); + was warning := TRUE + FI; + SYMBOL VAR function :: symb; + function.name := name of (function.no). + +treat wrong function name: + IF symb.type = var OR symb.type = array + THEN basic error (2, symb.name, "Funktionsname muß mit FN beginnen") + ELSE basic error (2, NAME symb, "Funktionsname erwartet") + FI. + +store label of function: + IF last label no < label list size + THEN last label no INCR 1 + ELSE errorstop ("Zu viele Label") + FI; + declare (label list [last label no]); + TEXT VAR dim text :: ""; + dim text CAT last label no; + recognize (function.no, user fn, niladr, function.data, dim text). + +get all params: + set scope (function.name + "?"); + next symbol; + IF symb.type = del AND symb.no = open bracket + THEN REP + try to get a param; + try to get del + UNTIL symb.no = close bracket OR + (symb.type <> del AND symb.type <> var) PER; + skip close bracket + FI. + +try to get a param: + REP + IF symb.type <> var + THEN next symbol + FI; + IF symb.type <> var + THEN careful error (2, NAME symb, "Parametervariable erwartet"); + IF symb.type <> del + THEN next symbol + FI + ELSE treat param + FI + UNTIL symb.type <> del OR symb.no = close bracket PER. + +treat param: + IF NOT known (symb.no) + THEN declare var (symb, nil); + ELIF already appeared in param list + THEN careful error (89, symb.name, ""); + FI; + dim text CAT symb.no. + +already appeared in param list: + INT VAR param counter; + FOR param counter FROM 2 UPTO LENGTH dim text DIV 2 REP + IF (dim text ISUB param counter) = symb.no + THEN LEAVE already appeared in param list WITH TRUE + FI + PER; + FALSE. + +try to get del: + IF symb.type = var + THEN next symbol + FI; + IF symb.type = var OR (symb.type = del CAND (symb.no <> comma AND symb.no <> close bracket)) + THEN careful error (2, symb.name, " , in Parameterliste erwartet") + FI. + +skip close bracket: + IF symb.type = del AND symb.no = close bracket + THEN next symbol + ELSE careful error (2, NAME symb, " ) nach Parameterliste erwartet") + FI. + +get function definition: + scope compulsory (FALSE); + skip (equal, operator); + generate forward jump; + define this label; + get expr (expr result, function.data); + recognize (function.no, user fn, expr result.adr, function.data, dim text); + goret; + define (behind); + scope compulsory (TRUE); + set scope (""). + +generate forward jump: + LABEL VAR behind; + declare (behind); + apply (behind). + +define this label: + define (label list [last label no]). + + +def type statement: +(*DEFINT/DBL/SNG/STR <range(s) of letters> *) + deftype := symb.no; + next symbol; + REP get letter (begin range); + IF symb.type = operator AND symb.no = minus + THEN next symbol; + get letter (end range) + ELSE end range := begin range FI; + + IF name of (begin range.no) > name of (end range.no) + THEN basic error (87, begin range.name + "-" + end range.name, "") + ELSE define chars (name of (begin range.no), name of (end range.no), data type) FI; + + IF symb.type = eos + THEN LEAVE def type statement + ELSE skip (comma, del) FI + PER . + +data type: + SELECT deftype OF + CASE defint s: int type + CASE defstr s: text type + OTHERWISE real type ENDSELECT . + + dim statement: +(*DIM <list of subscripted var results> *) + next symbol; + REP get field var; + get field size; + declare field; + + IF symb.type = eos + THEN LEAVE dim statement + ELSE skip (comma, del) FI + PER . + +get field var: + IF symb.type = array + THEN IF known (symb.no) + THEN basic error (10, symb.name, "") + ELSE field := symb; + next symbol + FI + ELIF symb.type = var + THEN basic error (2, symb.name, "Dimensionsangabe fehlt") + ELSE basic error (2, NAME symb, "Feldname erwartet") + FI. + +get field size: + field size := ""; + field elems := 1; + skip (open bracket, del); + + REP get const (size, int type); + INT CONST field limit :: size.name ISUB 1; + IF field limit < array base + THEN basic error (88, NAME size, "Die Obergrenze muß >= " + + text (array base) + " sein") + ELSE field size CAT (mki (field limit)); + field elems := field elems * (field limit + 1 - array base) + FI; + + IF symb.type = del AND symb.no = close bracket + THEN next symbol; + LEAVE get field size + ELSE skip (comma, del) FI + PER . + +declare field: + field size CAT mki (array base); + field size CAT mki (field elems); + declare var (field, field size) . + +end statement: +(*END *) + next symbol; + parameter (1, void type, const, nil adr); + apply (1, 0, ret) . + +error statement: +(*ERROR <integer expr result> *) + next symbol; + get expr (expr result, int type); + parameter (1, int type, const, expr result.adr); + parameter (2, text type, const, niltext value); + apply (1, 2, "errorstop") . + +gosub statement: +(*GOSUB <line number> *) + next symbol; + get const (label, int type); + gosub (this label) . + +goto statement : +(*GOTO <line number> *) + next symbol; + get const (label, int type); + apply (this label) . + +this label: label list [label pos (label no)] . +label no: label.name ISUB 1 . + +input statement: +(*INPUT [;]["Anfrage" ;/,] Variable [, Variable] *) + ROW 100 DTYPE VAR input var data; + INT VAR number input vars; + LABEL VAR input lab; + next symbol; + declare (input lab); + define (input lab); + get semicolon for cr lf; + get question and question mark; + apply (1, 3, "readinput"); + get input eof; + get data types of input vars (input var data, number input vars); (* F25/rr *) + check data types of input vars; (* F8/F25/rr *) + apply (1, 0, "inputok"); + apply (input lab, FALSE); + assign list of input var . (* F8/F25/rr *) + +get semicolon for cr lf: + IF symb.type = del AND symb.no = semicolon + THEN next symbol; + parameter (1, bool type, const, false value) + ELSE parameter (1, bool type, const, true value) FI . + +get question and question mark: + IF symb.type = const AND symb.data = text type + THEN get const (question, text type); + parameter (2, text type, const, question.adr); + parameter (3, bool type, const, question mark value); + next symbol + ELSE parameter (2, text type, const, niltext value); + parameter (3, bool type, const, true value); (* F7/rr *) + FI . + +question mark value: + IF symb.type = del AND symb.no = semicolon + THEN true value + ELIF symb.type = del AND symb.no = comma + THEN false value + ELSE basic error (2, NAME symb, " ; oder , erwartet"); nil adr FI . + +get input eof: + IF symb.type = res word AND symb.no = eof s + THEN next symbol; + get const (label, int type); + apply (1, 0, "inputeof"); + apply (this label, TRUE) + FI . + +check data types of input vars : (* F8/F25/rr *) + FOR i FROM 1 UPTO number input vars + REP parameter (1, int type, const, input data type); + apply (1, 1, "checkinput"); + apply (input lab, FALSE); + PER . + +input data type : (* F8/F25/rr *) + IF input var data (i) = int type THEN one value + ELIF input var data (i) = real type THEN two value + ELIF input var data (i) = text type THEN three value + ELSE zero value + FI . + +assign list of input var : (* F8/F25/rr *) + REP get var (var result); + parameter (1, var result. data, var, var result. adr); + apply (1, 1, "assigninput"); + + IF symb.type = del AND symb.no = comma + THEN next symbol + ELSE LEAVE assign list of input var FI + PER . + +kill statement: +(*KILL <filename> *) + next symbol; + get expr (filename, text type); + + parameter (1, text type, const, filename.adr); + parameter (2, quiet type, const, next local adr (int type)); + apply (2, 0, "quiet"); + apply (1, 2, "forget") . + +let statement: +(*[LET] <var> = <expression> *) + IF symb.type = res word AND symb.no = let s + THEN next symbol FI; + get var (var result); + skip (equal, operator); + get expr (expr result, var result.data); + apply move (var result.adr, expr result.adr, var result.data). + +line statement: (* F9/rr *) +(*1. LINE INPUT [;][<"prompt string">;]<string var result> *) + next symbol; + skip (input s, res word); + get semicolon; + get prompt string; + apply (1, 3, "readinput"); + assign string var result . + +get semicolon: + IF symb.type = del AND symb.no = semicolon + THEN next symbol; + parameter (1, bool type, const, false value) + ELSE parameter (1, bool type, const, true value) FI . + +get prompt string: + IF symb.type = const AND symb.data = text type + THEN get const (question, text type); + parameter (2, text type, const, question.adr); + skip (semicolon, del); + ELSE parameter (2, text type, const, niltext value); + FI; + parameter (3, bool type, const, false value) . + +assign string var result : + get var (var result, text type); + parameter (1, text type, var, var result.adr); + apply (1, 1, "assigninputline") . + +lprint statement: +(*LPRINT (cf. PRINT) *) + apply (1, 0, "switchtoprintoutfile"); + print statement; + apply (1, 0, "switchbacktooldsysoutstate"). + +l set statement: +(*LSET <string var> = <string expression> *) + next symbol; + get var (var result, text type); + skip (equal, operator); + get expr (expr result, text type); + parameter (1, text type, var, var result.adr); + parameter (2, text type, const, expr result.adr); + apply (1, 2, "lset") . + +mid statement: +(*MID$ (<string var>, from [,len]) = <string expression> *) + next symbol; + skip (open bracket, del); + get var (var result, text type); + skip (comma, del); + get expr (from, int type); + IF symb.type = del AND symb.no = comma + THEN next symbol; + get expr (len, int type) + ELSE len := nilsymbol FI; + skip (close bracket, del); + skip (equal, operator); + get expr (expr result, text type); + + parameter (1, text type, var, var result.adr); + parameter (2, int type, const, from.adr); + parameter (3, text type, const, expr result.adr); + IF len.data = int type + THEN parameter (4, int type, const, one value); + parameter (5, int type, const, len.adr); + parameter (6, text type, var, next local adr (text type)); + apply (3, 3, "subtext"); + parameter (3, text type, const, local adr); + FI; + apply (1, 3, "replace") . + +name statement: +(*NAME <old filename> AS <new filename> *) + next symbol; + get expr (old name, text type); + skip (as s, res word); + get expr (new name, text type); + parameter (1, text type, const, old name.adr); + parameter (2, text type, const, new name.adr); + apply (1, 2, "rename") . + +option statement: +(*OPTION BASE 0|1 *) + next symbol; + skip (base s, res word); + get const (base size, int type); + IF new array base > 1 + THEN basic error (105, NAME base size, "") + ELSE array base := new array base + FI. + +new array base: + base size.name ISUB 1. + +randomize statement: +(*RANDOMIZE [<expression>] *) + next symbol; + IF symb.type = eos + THEN apply (1, 0, "initrnd") + ELSE get expr (expr result, real type); + parameter (1, real type, const, expr result.adr); + apply (1, 1, "initrnd") + FI . + +read statement: +(*READ <list of var> *) + next symbol; + REP get var (var result); + parameter (1, text type, const, data text); + parameter (2, int type, var, data pos); + parameter (3, var result.data, var, var result.adr); + apply (1, 3, "read"); + + IF symb.type = eos + THEN LEAVE read statement + ELSE skip (comma, del) FI + PER . + +rem statement: +(*REM <remark> *) + next statement; + symb := SYMBOL : ("", eol, eos, LOC 0, void type); + LEAVE get basic line . + +restore statement: +(*RESTORE [<line number>] *) + next symbol; + IF symb.type = eos + THEN parameter (1, int type, var, data pos); + parameter (2, int type, const, one value); + parameter (3, void type, const, nil adr); + apply (1, 2, int move); + ELSE get const (label, int type); + parameter (1, text type, const, data text); + parameter (2, int type, var, data pos); + parameter (3, int type, const, label.adr); + apply (1, 3, "restore") + FI . + +return statement : +(*RETURN *) + next symbol; + goret . + +r set statement: +(*RSET <string var> = <string expression> *) + next symbol; + get var (var result, text type); + skip (equal, operator); + get expr (expr result, text type); + parameter (1, text type, var, var result.adr); + parameter (2, text type, const, expr result.adr); + apply (1, 2, "rset") . + +stop statement: +(*STOP *) + next symbol; + expr result := SYMBOL: (nil, any, const, nil adr, int type); + expr result.name CAT act stat no; + declare const (expr result, int type); + parameter (1, int type, const, expr result.adr); + apply (1, 1, "basicstop"); + parameter (1, void type, const, nil adr); + apply (1, 0, ret) . + +swap statement: +(*SWAP <var>,<var> *) + next symbol; + get var (var result); + parameter (1, var result.data, var, var result.adr); + DTYPE CONST first var result data :: var result.data; + skip (comma, del); + get var (var result); + IF first var result data = var result.data + THEN parameter (2, var result.data, var, var result.adr); + apply (1, 2, "swap") + ELSE basic error (106, var result.name, "gefunden: " + + dump (first var result data) + ", " + dump (var result.data)) + FI. + +troff statement: +(*TROFF *) + next symbol; + basic trace := FALSE . + +tron statement: +(*TRON *) + next symbol; + basic trace := TRUE . + +width statement: +(*WIDTH Größe *) + next symbol; + get expr (expr result, int type); + parameter (1, int type, const, expr result.adr); + apply (1, 1, "width") . + +write statement: +(*WRITE [<list of expr results>] *) + next symbol; + + IF symb.type = eos + THEN apply (1, 0, "nextline") + ELSE write list of expr results FI . + +write list of expr results: + REP get expr (expr result); + parameter (1, expr result.data, const, expr result.adr); + apply (1, 1, "basicwrite"); + + IF symb.type = eos + THEN apply (1, 0, "nextline"); + LEAVE write list of expr results + ELSE skip (comma, del); + parameter (1, text type, const, comma value); + apply (1, 1, "basicout") + FI + PER . + +END PROC get basic line; + +PROC gen stat no (INT CONST local stat no): +(* Die Zeilennummer wird als Label definiert *) +(* Die Prozedur 'stat no' wird mit der Statementnummer aufgerufen *) + act stat no := local stat no; + define (label list [label pos (act stat no)]); + + declare (1, int type); + declare (1, const); + define (1, act stat no); + parameter (2, void type, const, nil adr); + apply (1, 1, ln op); + + IF basic trace + THEN expr result := SYMBOL: (nil, any, const, nil adr, int type); + expr result.name CAT act stat no; + declare const (expr result, int type); + parameter (1, int type, const, expr result.adr); + apply (1, 1, trace op) + FI; + next symbol . + +END PROC gen stat no; + +PROC for statement: +(*FOR <var> = x TO y [STEP z] *) + SYMBOL VAR local var result, init val, limit val, step val; + LABEL VAR start loop, end loop; + INT CONST for stat no := act stat no, (* F29/rr *) + for scan line no := scan line no; + TEXT CONST for symb name := symb.name; + declare (start loop); + declare (end loop); + + next symbol; + get loop var; + skip (equal, operator); + get expr (init val, local var result.data); + skip (to s, res word); + get expr (limit val, local var result.data); + get step val; + + init loop var; + define (start loop); + gen check of variable; + get statement group (next s); + + IF symb.type = eos AND symb.no = -next s + THEN next var statement + ELSE define (end loop); + basic error ("Compiler", 26, for scan line no, for stat no, for symb name, "", TRUE); (* F29/rr *) + FI . + +get loop var: + get var (local var result); + IF NOT (local var result.data = int type OR local var result.data = real type) + THEN basic error (2, NAME local var result, "INT oder REAL erwartet, " + + dump (local var result.data) + " gefunden") + FI . + +get step val: + IF symb.type = res word AND symb.no = step s + THEN next symbol; + get expr (step val, local var result.data) + ELIF local var result.data = int type + THEN step val.data := int type; + step val.adr := int one value + ELSE step val.data := real type; + step val.adr := real one value + FI . + +init loop var: + IF local var result.data = int type + THEN init int loop + ELSE init real loop FI . + +init int loop: + IF limit val.type = var + THEN parameter (1, int type, var, next local adr (int type)); + parameter (2, int type, const, limit val.adr); + parameter (3, void type, const, nil adr); + apply (1, 2, int move); + limit val.adr := local adr; + FI; + IF step val.type = var + THEN parameter (1, int type, var, next local adr (int type)); + parameter (2, int type, const, step val.adr); + parameter (3, void type, const, nil adr); + apply (1, 2, int move); + step val.adr := local adr; + FI; + IF NOT (init val.no = local var result.no) + THEN parameter (1, int type, var, local var result.adr); + parameter (2, int type, const, init val.adr); + parameter (3, void type, const, nil adr); + apply (1, 2, int move) + FI . + +init real loop: + IF limit val.type = var + THEN parameter (1, real type, var, next local adr (real type)); + parameter (2, real type, const, limit val.adr); + parameter (3, void type, const, nil adr); + apply (1, 2, real move); + limit val.adr := local adr; + FI; + IF step val.type = var + THEN parameter (1, real type, var, next local adr (real type)); + parameter (2, real type, const, step val.adr); + parameter (3, void type, const, nil adr); + apply (1, 2, real move); + step val.adr := local adr; + FI; + IF NOT (init val.no = local var result.no) + THEN parameter (1, real type, var, local var result.adr); + parameter (2, real type, const, init val.adr); + parameter (3, void type, const, nil adr); + apply (1, 2, real move) + FI . + +gen check of variable: + parameter (1, local var result.data, const, local var result.adr); + parameter (2, limit val.data, const, limit val.adr); + parameter (3, step val.data, const, step val.adr); + parameter (4, bool type, const, nil adr); apply (4, nop); +(* In der nächsten Coder-Version ist eine PUSH-Angabe nop nicht nötig *) + apply (1, 3, "loopend"); + apply (end loop, TRUE) . + +next var statement: +(*NEXT [<var>][,<var>...] *) + next symbol; + generate loop end; + IF symb.type <> eos + THEN check next var result FI . + +check next var result: + IF symb.no = local var result.no + THEN next symbol; + IF symb.type = del AND symb.no = comma + THEN next for loop FI + ELSE basic error (86, NAME symb, local var result.name + " erwartet") FI . + +next for loop: + IF end symbol = next s + THEN symb := SYMBOL:("", -next s, eos, nil adr, void type) + ELSE basic error (1, symb.name, "") (* mo *) + FI. + +generate loop end: + parameter (1, local var result.data, var, local var result.adr); + parameter (2, step val.data, const, step val.adr); + parameter (3, void type, const, nil adr); + IF local var result.data = int type + THEN apply (1, 2, int incr) + ELSE apply (1, 2, real incr) FI; + + apply (start loop); + define (end loop) . + +END PROC for statement; + +PROC if statement : (* Änd. 11.08.87, mo *) +(* IF <expression> THEN <statement(s)>|<line number> *) +(* [ELSE <statement(s)>|<line number>] *) +(* IF <expression> GOTO <line number> *) +(* [ELSE <statement(s)>|<line number>] *) + SYMBOL VAR local expr result; + next symbol; + get expr (local expr result, int type); + skip comma if there; + IF symb.type = res word AND (symb.no = then s OR symb.no = goto s) + THEN test expr result; + IF symb.no = goto s + THEN next symbol; + if goto statement + ELIF next symbol is stat no + THEN if goto statement + ELSE if then statement + FI + ELSE basic error (2, NAME symb, "THEN oder GOTO erwartet") FI . + +skip comma if there: + IF symb.no = comma AND symb.type = del + THEN next symbol + FI. + +test expr result: + parameter (1, int type, const, local expr result.adr); + parameter (2, bool type, var, nil adr); apply (2, nop); + apply (1, 1, test) . + +next symbol is stat no: + next symbol; + symb.type = const AND symb.data = int type. + +if goto statement: + SYMBOL VAR stat label; + get const (stat label, int type); + expect else if comma found; + IF symb.type = res word AND symb.no = else s + THEN apply (this label, FALSE); + treat else case + ELIF symb.type <> eos OR symb.no <> eol + THEN declare (else label); + apply (this label, FALSE); + apply (else label); + get basic line (else s); + IF symb.type = eos AND symb.no = -else s + THEN else statement + ELSE define (else label) + FI + ELSE apply (this label, FALSE) + FI. + +this label: label list [label pos (label no)] . +label no: stat label.name ISUB 1 . + +expect else if comma found: + IF symb.type = del AND symb.no = comma + THEN next symbol; + IF symb.no <> else s OR symb.type <> res word + THEN basic error (2, NAME symb, "ELSE erwartet") + FI + FI. + +treat else case: + IF next symbol is stat no + THEN get const (stat label, int type); + apply (this label) + ELSE get basic line + FI. + +if then statement: + LABEL VAR fi label; + declare (else label); + apply (else label, TRUE); + get basic line (else s); + + IF symb.type = eos AND symb.no = -else s + THEN declare (fi label); + apply (fi label); + else statement; + define (fi label) + ELSE define (else label) FI . + + +else statement: + LABEL VAR else label; + define (else label); + treat else case. + + +END PROC if statement; + +PROC on statement: +(*2. ON <expression> GOSUB <list of line numbers> *) +(*3. ON <expression> GOTO <list of line numbers> *) + LABEL VAR before case, after case, return case; + declare (before case); + declare (after case); + declare (return case); + + next symbol; + IF symb.type = res word AND symb.no = error s + THEN basic error (100, symb.name, "") + FI; + get expr (expr result, int type); + IF on gosub statement + THEN gosub (before case); + apply (after case) + ELIF NOT on goto statement + THEN basic error (2, symb.name, "GOTO oder GOSUB erwartet") FI; + + get case stat no; + define (before case); + gen case branches; + gen return case; + define (after case) . + +on gosub statement: + BOOL CONST gosub found := symb.type = res word AND symb.no = gosub s; + gosub found . + +on goto statement: + symb.type = res word AND symb.no = goto s. + +get case stat no: + TEXT VAR case stat no :: nil; + INT VAR case no :: 0; + next symbol; + REP get const (label, int type); + case no INCR 1; + case stat no CAT label.name; + + IF symb.type = eos + THEN LEAVE get case stat no + ELSE skip (comma, del) FI + PER . + +gen case branches: + computedbranch (expr result.adr, case no + 1, otherwise lab); (* F6/rr *) + apply (otherwise lab); + FOR i FROM 1 UPTO case no + REP apply (label i) PER . + +gen return case: + IF gosub found + THEN define (return case); + goret + FI . + +otherwise lab: + IF gosub found + THEN return case + ELSE after case FI . + +label i: + label list [label pos (case stat no ISUB i)] . + +END PROC on statement; + +PROC print statement: +(*PRINT [<list of expr results>] *) +(*PRINT USING <string exp>;<list of expression> *) +(*PRINT #<file number>,<list of expr results> *) +(*PRINT #<file number>, USING <string exp>;<list of expression> *) + next symbol; + IF symb.type = del AND symb.no = numbersign + THEN print file statement + ELSE print display statement FI . + +print file statement: + basic error (100, symb.name, "") . + +print display statement: + get format string; + print list of expr results; + reset format string . + +get format string: + IF symb.type = res word AND symb.no = using s + THEN next symbol; + get expr (image, text type); + skip (semicolon, del); + parameter (1, text type, const, image.adr); + apply (1, 1, "using"); + ELSE image := nilsymbol FI . + +reset format string: + IF image.type <> any + THEN apply (1, 0, "clearusing") FI . + +print list of expr results: + REP IF symb.type = res word AND symb.no = tab s + THEN get tabulation + ELIF symb.type = del AND symb.no = comma + THEN get next zone + ELIF symb.type = del AND symb.no = semicolon + THEN get next pos + ELIF symb.type = eos + THEN apply (1, 0, "nextline"); + LEAVE print list of expr results + ELSE get print expr result FI; + PER . + +get tabulation: + next symbol; + skip (open bracket, del); + get expr (tab pos, int type); + skip (close bracket, del); + parameter (1, int type, const, tab pos.adr); + apply (1, 1, "tab") . + +get next zone: + next symbol; + IF image.type = any + THEN apply (1, 0, "nextzone") FI; + IF symb.type = eos + THEN LEAVE print list of expr results FI . + +get next pos: + next symbol; + IF symb.type = eos + THEN LEAVE print list of expr results FI . + +get print expr result: + get expr (expr result); + parameter (1, expr result.data, const, expr result.adr); + apply (1, 1, "basicout") . + +END PROC print statement; + +PROC while statement: +(*WHILE <expression> *) + LABEL VAR while lab, wend lab; + SYMBOL VAR while expr result; + INT CONST while stat no := act stat no, (* F29/rr *) + while scan line no := scan line no; + TEXT CONST while symb name := symb.name; + next symbol; + declare (while lab); + declare (wend lab); + + define (while lab); + get expr (while expr result, int type); + parameter (1, int type, const, while expr result.adr); + parameter (2, bool type, const, nil adr); apply (2, nop); + apply (1, 1, test); + apply (wend lab, TRUE); (* 'test' vergleicht mit 0 *) + + get statement group (wend s); + IF symb.type = eos AND symb.no = -wend s + THEN wend statement + ELSE basic error ("Compiler", 29, while scan line no, while stat no, while symb name, "", TRUE) FI. (* F29/rr *) + +wend statement: +(*WEND *) + apply (while lab); + define (wend lab); + next symbol . + +END PROC while statement; + +END PACKET basic compiler + diff --git a/lang/basic/1.8.7/src/BASIC.Runtime b/lang/basic/1.8.7/src/BASIC.Runtime new file mode 100644 index 0000000..854002a --- /dev/null +++ b/lang/basic/1.8.7/src/BASIC.Runtime @@ -0,0 +1,1571 @@ +(***************************************************************************) +(* *) +(* Erste von drei Dateien des EUMEL-BASIC-Systems *) +(* *) +(* Autor: Heiko Indenbirken *) +(* Überarbeitet von: Rudolf Ruland und Michael Overdick *) +(* *) +(* Stand: 27.10.1987 *) +(* *) +(***************************************************************************) + +PACKET basic std DEFINES EQU, UEQ, (* Autor: Heiko Indenbirken *) + LES, LEQ, (* Stand: 23.10.1987/rr/mo *) + GRE, GEQ, + EQV, IMP, + ^, swap, + val, asc, cdbl, chr, + cint, cvi, cvd, fre, + hex, inchars, + instr, ent, left, + mid, mki, mkd, + oct, right, + rnd, init rnd, + space, string, + l set, r set, + int not, real not, + /, DIV, real mod, + time, timer, + arctan, cos, sin, tan, + exp, ln, floor, + sqrt: + + +INT CONST true := -1, + false := 0; + +LET real overflow = 6; + + +(*BASIC-Integervergleiche *) +INT OP EQU (INT CONST a, b): + IF a=b + THEN true + ELSE false FI +END OP EQU; + +INT OP UEQ (INT CONST a, b): + IF a=b + THEN false + ELSE true FI +END OP UEQ; + +INT OP LES (INT CONST a, b): + IF a<b + THEN true + ELSE false FI +END OP LES; + +INT OP LEQ (INT CONST a, b): + IF a<=b + THEN true + ELSE false FI +END OP LEQ; + +INT OP GRE (INT CONST a, b): + IF a>b + THEN true + ELSE false FI +END OP GRE; + +INT OP GEQ (INT CONST a, b): + IF a>=b + THEN true + ELSE false FI +END OP GEQ; + +(*BASIC-Realvergleiche *) +INT OP EQU (REAL CONST a, b): + IF a=b + THEN true + ELSE false FI +END OP EQU; + +INT OP UEQ (REAL CONST a, b): + IF a=b + THEN false + ELSE true FI +END OP UEQ; + +INT OP LES (REAL CONST a, b): + IF a<b + THEN true + ELSE false FI +END OP LES; + +INT OP LEQ (REAL CONST a, b): + IF a<=b + THEN true + ELSE false FI +END OP LEQ; + +INT OP GRE (REAL CONST a, b): + IF a>b + THEN true + ELSE false FI +END OP GRE; + +INT OP GEQ (REAL CONST a, b): + IF a>=b + THEN true + ELSE false FI +END OP GEQ; + +(*BASIC-Tesxtvergleiche *) +INT OP EQU (TEXT CONST a, b): + IF a=b + THEN true + ELSE false FI +END OP EQU; + +INT OP UEQ (TEXT CONST a, b): + IF a=b + THEN false + ELSE true FI +END OP UEQ; + +INT OP LES (TEXT CONST a, b): + IF a<b + THEN true + ELSE false FI +END OP LES; + +INT OP LEQ (TEXT CONST a, b): + IF a<=b + THEN true + ELSE false FI +END OP LEQ; + +INT OP GRE (TEXT CONST a, b): + IF a>b + THEN true + ELSE false FI +END OP GRE; + +INT OP GEQ (TEXT CONST a, b): + IF a>=b + THEN true + ELSE false FI +END OP GEQ; + + +(*BASIC INTEGER / BOOL Operatoren *) +REAL PROC real not (REAL CONST a): (* mo *) + real (int (a) XOR -1) +END PROC real not; + +INT PROC int not (INT CONST a): (* mo *) + a XOR -1 +END PROC int not; + +INT OP EQV (INT CONST l, r): + int not (l XOR r) +END OP EQV; + +INT OP IMP (INT CONST l, r): + (l EQV r) OR r +END OP IMP; + +LET smallest significant = 5.0e-12; +REAL OP ^ (REAL CONST x, y): (* F22/rr *) + IF x > 0.0 + THEN x ** y + ELIF x = 0.0 + THEN IF y > 0.0 + THEN 0.0 + ELIF y = 0.0 + THEN 1.0 + ELSE errorstop (real overflow, ""); + max real + FI + ELSE REAL VAR floor y := floor (y + round value); + IF (abs (y - floor y) > smallest significant) + COR (floor y = 0.0 AND y <> 0.0) + THEN errorstop (1005, "bei " + text (x) + + " ^ " + text (y, 19) + + " : neg. Basis, gebr. Exponent"); + 0.0 + ELIF (floor y MOD 2.0) = 0.0 + THEN (-x) ** floor y + ELSE - ( (-x) ** floor y ) + FI + FI . + + round value : IF y >= 0.0 THEN 0.5 ELSE -0.5 FI . + +END OP ^; + +REAL OP ^ (INT CONST x, y): + real (x) ** y +END OP ^; + +REAL OP / (INT CONST l, r): (* mo *) + real (l) / real (r) +END OP /; + +INT OP DIV (REAL CONST l, r): (* mo *) + cint (l) DIV cint (r) +END OP DIV; + +REAL PROC real mod (REAL CONST l, r): (* mo *) + round (l, 0) MOD round (r, 0) +END PROC real mod; + +(* Basic Arithmetik *) +REAL VAR r swap; +PROC swap (REAL VAR left, right): + r swap := left; + left := right; + right := r swap +END PROC swap; + +INT VAR i swap; +PROC swap (INT VAR left, right): + i swap := left; + left := right; + right := i swap +END PROC swap; + +TEXT VAR t swap; +PROC swap (TEXT VAR left, right): + t swap := left; + left := right; + right := t swap +END PROC swap; + +(*Internkonvertierungen *) +INT PROC cvi (TEXT CONST v): + v ISUB 1 +END PROC cvi; + +REAL PROC cvd (TEXT CONST v): + v RSUB 1 +END PROC cvd; + +TEXT VAR i text :: 2*""0"", r text :: 8*""0""; +TEXT PROC mki (REAL CONST x): + mki (cint (x)) +END PROC mki; + +TEXT PROC mki (INT CONST i): + replace (i text, 1, i); + i text +END PROC mki; + +TEXT PROC mkd (INT CONST i): + mkd (real (i)) +END PROC mkd; + +TEXT PROC mkd (REAL CONST r): + replace (r text, 1, r); + r text +END PROC mkd; + +(*Textoperationen *) +PROC l set (TEXT VAR left, TEXT CONST right): + replace (left, 1, right) +END PROC l set; + +PROC r set (TEXT VAR left, TEXT CONST right): + replace (left, length (left)-length (right)+1, right) +END PROC r set; + +TEXT PROC left (TEXT CONST string, REAL CONST no): + left (string, cint (no)) +END PROC left; + +TEXT PROC left (TEXT CONST string, INT CONST no): + subtext (string, 1, no) +END PROC left; + +TEXT PROC right (TEXT CONST string, REAL CONST no): + right (string, cint (no)) +END PROC right; + +TEXT PROC right (TEXT CONST string, INT CONST no): + subtext (string, length (string)-no+1) +END PROC right; + +TEXT PROC mid (TEXT CONST source, REAL CONST from): + mid (source, cint (from)) +END PROC mid; + +TEXT PROC mid (TEXT CONST source, INT CONST from): + subtext (source, from) +END PROC mid; + +TEXT PROC mid (TEXT CONST source, REAL CONST from, length): + mid (source, cint (from), cint (length)) +END PROC mid; + +TEXT PROC mid (TEXT CONST source, INT CONST from, length): + subtext (source, from, from+length-1) +END PROC mid; + +TEXT PROC string (REAL CONST x, y): + string (cint (x), cint (y)) +END PROC string; + +TEXT PROC string (INT CONST x, REAL CONST y): + string (x, cint (y)) +END PROC string; + +TEXT PROC string (REAL CONST x, INT CONST y): + string (cint (x), y) +END PROC string; + +TEXT PROC string (INT CONST i, j): + i * code (j) +END PROC string; + +TEXT PROC string (REAL CONST i, TEXT CONST x): + string (cint (i), x) +END PROC string; + +TEXT PROC string (INT CONST i, TEXT CONST x): + i * (x SUB 1) +END PROC string; + +(*Konvertierungen *) + +REAL PROC val (TEXT CONST text) : (* F18/rr *) + + TEXT VAR buffer := text; + change (buffer, "d", "e"); + change (buffer, "D", "e"); + change (buffer, "E", "e"); + real (buffer) + +END PROC val; + +REAL PROC asc (TEXT CONST text): + real (code (text SUB 1)) +END PROC asc; + +TEXT PROC chr (INT CONST n): + code (n) +END PROC chr; + +TEXT PROC chr (REAL CONST n): + code (cint (n)) +END PROC chr; + +TEXT PROC hex (REAL CONST x): + hex (cint (x)) +END PROC hex; + +TEXT PROC hex (INT CONST x): + TEXT VAR value :: "12"; + replace (value, 1, x); + high byte + low byte . + +low byte: + hexdigit (code (value SUB 1) DIV 16) + hexdigit (code (value SUB 1) MOD 16) . + +high byte: + IF (value SUB 2) = ""0"" + THEN "" + ELSE hexdigit (code (value SUB 2) DIV 16) + + hexdigit (code (value SUB 2) MOD 16) + FI . + +END PROC hex; + +TEXT PROC oct (REAL CONST x): + oct (cint (x)) +END PROC oct; + +TEXT PROC oct (INT CONST x): + INT VAR number :: x AND maxint; + generate oct number; + IF x < 0 + THEN "1" + oct number + ELSE subtext (oct number, pos (oct number, "1", "7", 1)) + FI. + +generate oct number: + TEXT VAR oct number :: ""; + INT VAR digit; + FOR digit FROM 1 UPTO 5 REP + oct number := hexdigit (number MOD 8) + oct number; + number := number DIV 8 + PER. + +END PROC oct; + +TEXT PROC hexdigit (INT CONST digit): + IF 0 <= digit AND digit <= 9 + THEN code (digit + 48) + ELIF 10 <= digit AND digit <= 15 + THEN code (digit + 55) + ELSE errorstop (1051, "Hexziffer außerhalb des gültigen Bereichs"); "" FI +END PROC hexdigit; + +TEXT PROC inchars (REAL CONST n): + inchars (cint (n)) +END PROC inchars; + +TEXT PROC inchars (INT CONST n): + TEXT VAR buffer :: "", char; + INT VAR i; + FOR i FROM 1 UPTO n + REP inchar (char); + buffer CAT char + PER; + buffer + +END PROC inchars; + +(*Mathematische Prozeduren *) +REAL PROC ent (INT CONST r): + real (r) +END PROC ent; + +REAL PROC ent (REAL CONST r): + IF r >= 0.0 OR frac (r) = 0.0 + THEN floor (r) + ELSE floor (r-1.0) FI +END PROC ent; + +REAL PROC cdbl (INT CONST r): + real (r) +END PROC cdbl; + +REAL PROC cdbl (REAL CONST r): + r +END PROC cdbl; + +INT PROC cint (INT CONST r): + r +END PROC cint; + +INT PROC cint (REAL CONST r): + IF r >= 0.0 + THEN int (r+0.5) + ELSE int (r-0.5) FI +END PROC cint; + +REAL VAR last rnd :: rnd (1.0); +REAL PROC rnd (INT CONST x): + rnd (real (x)) +END PROC rnd; + +REAL PROC rnd (REAL CONST x): + IF x > 0.0 + THEN last rnd := random; + last rnd + ELIF x = 0.0 + THEN last rnd + ELSE init rnd (x); + last rnd := random; + last rnd + FI + +END PROC rnd; + +REAL PROC rnd: + rnd (1.0) +END PROC rnd; + +PROC init rnd (REAL CONST init value) : + + REAL VAR init := init value; + IF init <= -1.0 OR 1.0 <= init + THEN set exp (- decimal exponent (init) - 1, init) FI; + initialize random (init) + +END PROC init rnd; + + +REAL PROC fre (TEXT CONST dummy): + INT VAR f, u; + collect heap garbage; + storage (f, u); + + real (f - u) * 1024.0 +END PROC fre; + +REAL PROC fre (REAL CONST dummy): + fre ("") +END PROC fre; + +REAL PROC fre (INT CONST dummy): + fre ("") +END PROC fre; + +(*Inputroutinenen *) +INT PROC instr (TEXT CONST source, pattern): + pos (source, pattern) +END PROC instr; + +INT PROC instr (REAL CONST from, TEXT CONST source, pattern): + instr (cint (from), source, pattern) +END PROC instr; + +INT PROC instr (INT CONST from, TEXT CONST source, pattern): + pos (source, pattern, from) +END PROC instr; + +TEXT PROC space (REAL CONST len): + space (cint (len)) +END PROC space; + +TEXT PROC space (INT CONST len): + len * " " +END PROC space; + +TEXT PROC time: (* mo *) + subtext (time (clock (1) MOD day), 1, 8) (* hh:mm:ss *) +END PROC time; + +REAL PROC timer: + clock (0) +END PROC timer; + +REAL PROC arctan (INT CONST x): + arctan (real (x)) +END PROC arctan; + +REAL PROC cos (INT CONST x): + cos (real (x)) +END PROC cos; + +REAL PROC sin (INT CONST x): + sin (real (x)) +END PROC sin; + +REAL PROC tan (INT CONST x): + tan (real (x)) +END PROC tan; + +REAL PROC exp (INT CONST x): + exp (real (x)) +END PROC exp; + +REAL PROC ln (INT CONST x): + ln (real (x)) +END PROC ln; + +REAL PROC floor (INT CONST x): + real (x) +END PROC floor; + +REAL PROC sqrt (INT CONST x): + sqrt (real (x)) +END PROC sqrt; + +END PACKET basic std; + +PACKET basic using DEFINES using, (* Autor: Heiko Indenbirken *) + clear using, (* Stand: 05.08.1987/rr/mo *) + basic text: + + +LET exclamation point = "!", + backslash = "\", + comercial and = "&", + numbersign = "#", + plus = "+", + minus = "-", + asterisk dollar = "**$", + asterisk = "**", + dollarsign = "$$", + comma = ",", + point = ".", + caret = "^^^^", + underscore = "_", + blank = " ", + nil = "", + + number format chars = "#+-*$.^", + format chars = "!\&#+-$*."; + +TEXT VAR result, using format :: "", pre format :: ""; +INT VAR using pos :: 0; +BOOL VAR image used :: FALSE; + +PROC using (TEXT CONST format): + using format := format; + using pos := 0; + result := ""; + image used := TRUE + +END PROC using; + +PROC clear using: + using format := ""; + image used := FALSE +END PROC clear using; + +TEXT PROC next format: + pre format := ""; + IF using pos = 0 + THEN "" + ELSE search rest of format FI . + +search rest of format: + WHILE using pos <= length (using format) + REP IF at underscore + THEN using pos INCR 1; + pre format CAT akt char + ELIF at format char + THEN LEAVE next format WITH pre format + ELSE pre format CAT akt char FI; + using pos INCR 1 + PER; + using pos := 0; + pre format . + +at underscore: + akt char = underscore . + +at format char: + pos (format chars, akt char) > 0 CAND + evtl double asterisk CAND + evtl point with numbersign . + +evtl double asterisk: + akt char <> asterisk COR next char = asterisk . + +evtl point with numbersign: + akt char <> point COR next char = numbersign . + +akt char: using format SUB using pos . +next char: using format SUB using pos+1 . +END PROC next format; + +PROC init (TEXT VAR l result): + IF using pos = 0 + THEN using pos := 1; + l result := next format; + IF using pos = 0 + THEN errorstop (1005, "USING: kein Format gefunden") FI + ELSE l result := "" FI + +END PROC init; + +TEXT PROC basic text (TEXT CONST string): + IF image used + THEN using text + ELSE string FI . + +using text: + init (result); + result CAT format string; + using pos INCR 1; + result CAT next format; + result . + +format string: + IF akt char = exclamation point + THEN string SUB 1 + ELIF akt char = backslash + THEN given length string + ELIF akt char = comercial and + THEN string + ELSE errorstop (1005, "USING-Format fehlerhaft: " + using format); "" FI . + +given length string: + INT VAR len :: 2; + FOR using pos FROM using pos+1 UPTO length (using format) + REP IF akt char = "\" + THEN LEAVE given length string WITH text (string, len) FI; + len INCR 1 + UNTIL akt char <> " "PER; + errorstop (1005, "USING-Format fehlerhaft: " + using format); + "" . + +akt char: using format SUB using pos +END PROC basic text; + +TEXT PROC basic text (INT CONST number): + IF image used + THEN basic text (real (number)) + ELSE sign + text (number) FI . + +sign: + IF number >= 0 + THEN " " + ELSE "" FI . + +END PROC basic text; + +TEXT PROC basic text (REAL CONST number): + IF image used + THEN using text + ELSE normal text FI . + +normal text: +(* Bei Real Zahlen werden maximal 7 signifikante Stellen ausgegeben, *) +(* führende und nachfolgende Nullen werden unterdrückt, *) +(* der Dezimalpunkt wird im Normalformat unterdrückt *) + calculate sign; + REAL VAR mantissa := round (abs (number), 6-decimal exponent (number)); + INT CONST exp :: decimal exponent (mantissa); + + IF mantissa = 0.0 + THEN result := " 0" + ELIF exp > 6 OR exp < -7 OR (exp < 0 AND more than 7 signifikant digits) + THEN scientific notation + ELIF exp < 0 + THEN short negative notation + ELSE short positive notation FI; + result . + +more than 7 signifikant digits: + REAL VAR signifikant := mantissa; + set exp (7+exp, signifikant); + frac (signifikant) <> 0.0 . + +calculate sign: + IF number >= 0.0 + THEN result := " " + ELSE result := "-" FI . + +scientific notation: + set exp (0, mantissa); + result CAT non zero (text (mantissa, 8, 6)); + + IF exp < 0 + THEN result CAT "E-" + ELSE result CAT "E+" FI; + + IF abs (exp) > 9 + THEN result CAT text (abs (exp)) + ELSE result CAT "0"; + result CAT text (abs (exp)) + FI . + +short positive notation: + result CAT non zero (text (mantissa, 8, 6-exp)); + IF (result SUB LENGTH result) = "." + THEN delete char (result, LENGTH result) FI . + +short negative notation: + result CAT non zero (subtext (text (abs (mantissa), 9, 7), 2)).(* F13/rr *) + +using text: + init (result); + result CAT format number (subformat, number); + result CAT next format; + result . + +subformat: + INT VAR from :: using pos, to :: last format char; + subtext (using format, from, to) . + +last format char: + FOR using pos FROM using pos+1 UPTO length (using format) + REP IF non format char + THEN LEAVE last format char WITH using pos-1 FI + PER; + using pos := 0; + length (using format) . + +non format char: + IF (using format SUB using pos) = comma + THEN (using format SUB (using pos+1)) <> point + ELSE pos (numberformat chars, using format SUB using pos) = 0 FI . + +END PROC basic text; + +TEXT PROC non zero (TEXT CONST text): + INT VAR i; + FOR i FROM length (text) DOWNTO 2 + REP UNTIL (text SUB i) <> "0" PER; + subtext (text, 1, i) +END PROC non zero; + +TEXT PROC format number (TEXT CONST format, REAL CONST number): + IF no digit char + THEN errorstop (1005, "USING-Format fehlerhaft: " + using format); "" + ELIF exponent found + THEN exponent format + ELSE normal format FI . + +no digit char: + pos (format, numbersign) = 0 AND + pos (format, asterisk) = 0 AND + pos (format, dollarsign) = 0 . + +exponent found: + INT CONST exponent pos := pos (format, caret); + exponent pos > 0 . + +exponent format: + IF leading plus + THEN plus or minus + exponent field (subtext (format, 2), number, exponent pos-1) + ELIF trailing plus + THEN exponent field (format, number, exponent pos) + plus or minus + ELIF trailing minus + THEN exponent field (format, number, exponent pos) + nil or minus + ELSE blank or minus + exponent field (subtext (format, 2), number, exponent pos-1) FI . + +normal format: + IF leading numbersign + THEN number field (format, number, "", " ") + ELIF leading point + THEN number field (format, number, "", " ") + ELIF leading plus + THEN number field (format, abs (number), plus or minus, " ") + ELIF leading asterisk dollar + THEN number field (format, number, "$", "*") + ELIF leading asterisk + THEN number field (format, number, "", "*") + ELIF leading dollarsign + THEN number field (format, number, "$", " ") + ELSE errorstop (1005, "USING-Format fehlerhaft: " + using format); "" FI . + +leading numbersign: (format SUB 1) = numbersign . +leading point: (format SUB 1) = point . +leading plus: (format SUB 1) = plus . +leading asterisk dollar: subtext (format, 1, 3) = asterisk dollar . +leading asterisk: subtext (format, 1, 2) = asterisk . +leading dollarsign: subtext (format, 1, 2) = dollarsign . + +trailing minus: (format SUB LENGTH format) = minus . +trailing plus: (format SUB LENGTH format) = plus . + +plus or minus: IF number < 0.0 THEN minus ELSE plus FI . +nil or minus: IF number < 0.0 THEN minus ELSE nil FI . +blank or minus: IF number < 0.0 THEN minus ELSE blank FI . + +END PROC format number; + +TEXT PROC exponent field (TEXT CONST format, REAL CONST value, INT CONST exponent pos): + REAL VAR number := abs (value); + INT CONST point pos := pos (format, point); + calc leading and trailing; + INT CONST new exponent :: decimal exponent (value) - leading + 1; + IF abs (new exponent) >= 100 + THEN "%" + mantissa + "E" + null text (new exponent, 4) + ELSE mantissa + exponent + FI. + +calc leading and trailing: + INT VAR leading, trailing; + IF point pos = 0 + THEN leading := exponent pos-1; + trailing := 0 + ELSE leading := point pos-1; + trailing := exponent pos-point pos-1 + FI . + +mantissa: + set exp (leading - 1, number); + IF point pos = 0 + THEN subtext (text (number, leading+1, 0), 1, leading) + ELSE subtext (text (number, leading+trailing+2, trailing), 2) FI . + +exponent: + "E" + null text (new exponent, 3) . + +END PROC exponent field; + +TEXT PROC number field (TEXT CONST format, REAL CONST value, + TEXT CONST pretext, lead char): + INT CONST point pos :: pos (format, point); + calc fraction; + calc digits; + calc commata if necessary; + fill with lead chars and sign . + +calc fraction: + INT VAR fraction :: 0, i; + FOR i FROM point pos+1 UPTO length (format) + WHILE (format SUB i) = numbersign + REP fraction INCR 1 PER . + +calc digits: + TEXT VAR valuetext; + IF point pos = 0 + THEN valuetext := digits (abs (value), 0, TRUE); + delete char (valuetext, length (valuetext)) + ELSE valuetext := digits (abs (value), fraction, point pos <> 1) FI . + +calc commata if necessary: + IF comma before point + THEN insert commata FI . + +comma before point: + point pos > 0 CAND (format SUB point pos-1) = comma . + +insert commata: + i := pos (valuetext, point)-3; + WHILE i > 1 CAND (valuetext SUB i) <> " " + REP insert char (valuetext, ",", i); + i DECR 3 + PER . + +fill with lead chars and sign: + IF trailing minus + THEN fillby (pretext + valuetext, length (format)-1, lead char) + nil or minus + ELIF trailing plus + THEN fillby (pretext + valuetext, length (format)-1, lead char) + plus or minus + ELIF value < 0.0 + THEN fillby (pretext + minus + valuetext, length (format), lead char) + ELSE fillby (pretext + valuetext, length (format), lead char) FI . + + +plus or minus: IF value < 0.0 THEN minus ELSE plus FI . +nil or minus: IF value < 0.0 THEN minus ELSE nil FI . +trailing minus: (format SUB LENGTH format) = minus . +trailing plus: (format SUB LENGTH format) = plus . +END PROC numberfield; + +TEXT PROC null text (INT CONST n, digits): + TEXT VAR l result := text (abs (n), digits); + IF n < 0 + THEN replace (l result, 1, "-") + ELSE replace (l result, 1, "+") FI; + change all (l result, " ", "0"); + l result . +END PROC null text; + +TEXT PROC fillby (TEXT CONST source, INT CONST format, TEXT CONST with): + IF differenz >= 0 + THEN differenz * with + source + ELSE "%" + source FI . + +differenz: format - length (source) . +END PROC fillby; + +TEXT PROC digits (REAL CONST value, INT CONST frac, BOOL CONST null): + IF decimal exponent (value) < 0 + THEN TEXT VAR l result := text (value, frac+2, frac); + + IF null AND first char <> "0" + THEN replace (l result, 1, "0"); + l result + ELIF (NOT null AND first char = "0") OR first char = " " + THEN subtext (l result, 2) + ELSE l result FI + ELSE text (value, decimal exponent (value)+frac+2, frac) FI . + +first char: + (l result SUB 1) . + +END PROC digits; + +TEXT PROC right (TEXT CONST msg, INT CONST len): + IF length (msg) >= len + THEN subtext (msg, 1, len) + ELSE (len - length (msg)) * " " + msg FI + +END PROC right; + +END PACKET basic using; + +PACKET basic output (* Autor: R. Ruland *) + (* Stand: 28.08.1987/rr/mo *) + DEFINES basic page, + width, + init output, + basic out, + basic write, + tab, + next zone, + next line, + next page, + cursor x pos, + pos, + csrlin, + l pos, + switch to printout file, + switch back to old sysout state: + +LET zone width = 16; (* sd.ddddddEsdddb (s = sign, d = digit, b = blank) *) +LET printfile name = "BASIC LPRINT OUTPUT"; + +INT VAR screen width, x cursor, y cursor, line no; +BOOL VAR paging := FALSE, first time, + in lprint; (* mo *) +TEXT VAR buffer, output line, last sysout file, old sysout, char; + +PROC basic page (BOOL CONST status): + + paging := status + +END PROC basic page; + +BOOL PROC basic page: paging END PROC basic page; + + +PROC width (INT CONST max): + + IF max < 0 + THEN errorstop (1005, "WIDTH: negatives Angabe: " + text (max)) + ELIF max = 0 + THEN screen width := 1 + ELSE screen width := max + FI; + last sysout file := ""; + +END PROC width; + +INT PROC width : screen width END PROC width; + + +PROC init output: + + clear using; + width (max (1, x size)); + line no := 1; + output line := ""; + first time := TRUE; + in lprint := FALSE + +END PROC init output; + + +PROC basic out (INT CONST i): bas out (basic text (i) + " ") END PROC basic out; + +PROC basic out (REAL CONST r): bas out (basic text (r) + " ") END PROC basic out; + +PROC basic out (TEXT CONST t): bas out (basic text (t)) END PROC basic out; + +PROC basic write (INT CONST i): bas out (basic text (i)) END PROC basic write; + +PROC basic write (REAL CONST r): bas out (basic text (r)) END PROC basic write; + +PROC basic write (TEXT CONST t): bas out (basic text ("""" + t + """")) END PROC basic write; + + +PROC bas out (TEXT CONST msg): + + get cursor; + IF length (msg) > free + THEN IF first time + THEN first time := FALSE; + next line; + bas out (msg); + ELSE buffer := subtext (msg, 1, free); + IF sysout = "" + THEN out (buffer) + ELSE sysout write (buffer) + FI; + next line; + buffer := subtext (msg, free + 1); + bas out (buffer); + FI; + ELSE first time := TRUE; + IF sysout = "" + THEN out (msg) + ELSE sysout write (msg) + FI; + FI; + + . free : screen width - x cursor + 1 + +END PROC bas out; + + +PROC tab (INT CONST n): + + get cursor; + IF n <= 0 + THEN tab position out of range + ELIF n > screen width + THEN tab (n MOD screen width); + ELIF x cursor > n + THEN next line; + tab (n); + ELIF sysout = "" + THEN cursor (n, y cursor); + ELSE buffer := (n - x cursor) * " "; + sysout write (buffer) + FI; + + . tab position out of range : + IF x cursor <> 1 THEN next line FI; + write ("WARNUNG : TAB-Position <= 0"); + next line; + +END PROC tab; + + +PROC next zone: + + get cursor; + IF x cursor > screen width - zone width + THEN next line; + ELIF sysout = "" + THEN free TIMESOUT " "; + ELSE buffer := free * " "; + sysout write (buffer) + FI; + + . free : ((x cursor - 1) DIV zone width + 1) * zone width - x cursor + 1 + +END PROC next zone; + + +PROC next line : + + IF sysout = "" + THEN next line on screen + ELSE line; + write (""); (* generates new record *) + output line := ""; + FI; + + . next line on screen: + line no INCR 1; + IF paging CAND line no > y size + THEN IF in last line + THEN warte; + ELSE out (""13""10""); + line no := y cursor + 1; + FI; + ELIF NOT paging + THEN char := incharety; + IF char <> "" + THEN IF char = "+" + THEN paging := TRUE + ELSE type (char) + FI + FI; + out (""13""10"") + ELSE out (""13""10"") + FI + + . in last line : + get cursor; + y cursor = y size + + . warte : + cursor (x size - 2, y size); + out (">>"); + inchar (char); + IF char = ""13"" + THEN next page + ELIF char = ""10"" + THEN out (""8""8" "13""10"") + ELIF char = ""27"" + THEN clear editor buffer; + errorstop (1, "") + ELIF char = "-" + THEN out (""8""8" "13""10""); + line no := 1; + paging := FALSE; + ELSE out (""8""8" "13""10""); + line no := 1; + FI; + + . clear editor buffer: + REP UNTIL get charety = "" PER; + +END PROC next line; + + +PROC next page: + + IF sysout = "" + THEN out (""1""4"") + ELSE line + FI; + clear using; + line no := 1; + output line := ""; + +END PROC next page; + + +INT PROC pos (REAL CONST dummy): (* mo *) + + cursor x pos + +END PROC pos; + + +INT PROC pos (INT CONST dummy): (* mo *) + + cursor x pos + +END PROC pos; + + +INT PROC cursor x pos : + + get cursor; + x cursor + +END PROC cursor x pos; + + +INT PROC csrlin: (* mo *) + + get cursor; + y cursor + +END PROC csrlin; + + +PROC get cursor : + + IF sysout = "" + THEN get cursor (x cursor, y cursor); + ELSE x cursor := LENGTH output line + 1; + FI; + +END PROC get cursor; + + +INT PROC l pos (REAL CONST dummy): (* mo *) + + l pos (0) + +END PROC l pos; + + +INT PROC l pos (INT CONST dummy): (* mo *) + + INT VAR lprint position :: 1; + IF exists (printfile name) + THEN disable stop; + FILE VAR printfile :: sequential file (modify, printfile name); + IF lines (printfile) > 0 + THEN to line (printfile, lines (printfile)); + lprint position := len (printfile) + 1 + FI; + output (printfile) + FI; + lprint position + +END PROC l pos; + + +PROC switch to printout file: (* mo *) + + in lprint := TRUE; + old sysout := sysout; + careful sysout (printfile name); + +END PROC switch to printout file; + + +PROC switch back to old sysout state: (* mo *) + + IF in lprint + THEN careful sysout (old sysout); + in lprint := FALSE + FI + +END PROC switch back to old sysout state; + + +PROC sysout write (TEXT CONST string): + check sysout; + write (string); + output line CAT string. + +check sysout: + IF sysout <> last sysout file + THEN careful sysout (sysout) + FI. + +END PROC sysout write; + + +PROC careful sysout (TEXT CONST new sysout): (* mo *) + +IF new sysout <> "" + THEN disable stop; + FILE VAR outfile :: sequential file (modify, new sysout); + max line length (outfile, screen width); + last sysout file := sysout; + IF lines (outfile) > 0 + THEN to line (outfile, lines (outfile)); + read record (outfile, output line); + delete record (outfile) + ELSE output line := "" + FI; + sysout (new sysout); + write (output line); + ELSE sysout ("") +FI + +END PROC careful sysout; + +END PACKET basic output; + + +PACKET basic input (* Autor: R. Ruland *) + (* Stand: 27.10.1987/rr/mo *) + + DEFINES init input, + read input, + check input, + assign input, + assign input line, + input ok, + input eof: + + +LET comma = ",", + quote = """", + + wrong type = 1, + insufficient data = 2, + too much data = 3, + overflow = 4, + + int overflow = 4, + real overflow = 6; + +INT VAR input line pos, input error no; +BOOL VAR on terminal; +TEXT VAR input line :: "", previous input line := "", input value; + +. first quote found : (input value SUB 1) = quote +.; + +PROC init input : + + input error no := 0; + input line pos := 0; + input line := ""; + previous input line := ""; + +END PROC init input; + + +PROC read input (BOOL CONST cr lf, TEXT CONST msg, BOOL CONST question mark): + + on terminal := sysout <> "" AND sysin = ""; + check input error; + out string (msg); + IF question mark THEN out string ("? ") FI; + IF sysin <> "" + THEN getline (input line); + ELSE editget input line; + FI; + out string (input line); + IF crlf THEN out line FI; + input line pos := 0; + input error no := 0; + + . check input error : + IF input error no = 0 + THEN input line := ""; + ELSE IF sysin = "" + THEN BOOL CONST old basic page := basic page; + basic page (FALSE); + IF cursor x pos <> 1 THEN next line FI; + basic out ("?Eingabe wiederholen ! (" + error text + ")"); + next line; + basic page (old basic page); + ELSE errorstop (1080,"INPUT-Fehler (" + error text + + ") : >" + input line + "<"); + FI; + FI; + + . error text : + SELECT input error no OF + CASE wrong type : "falscher Typ" + CASE insufficient data : "zu wenig Daten" + CASE too much data : "zu viele Daten" + CASE overflow : "Überlauf" + OTHERWISE : "" + END SELECT + + . editget input line : + TEXT VAR exit char; + INT VAR x, y; + get cursor (x, y); + REP IF width - x < 1 + THEN out (""13""10""); + get cursor (x, y) + FI; + editget (input line, max text length, width - x, "", "k", exit char); + cursor (x, y); + IF exit char = ""27"k" + THEN input line := previous input line; + ELSE previous input line := input line; + LEAVE editget input line; + FI; + PER; + +END PROC read input; + + +PROC out string (TEXT CONST string) : + + basic out (string); + IF on terminal THEN out (string) FI; + +END PROC out string; + + +PROC out line : + + next line; + IF on terminal THEN out (""13""10"") FI; + +END PROC out line; + + +BOOL PROC check input (INT CONST type) : + + get next input value; + input value := compress (input value); + set conversion (TRUE); + SELECT type OF + CASE 1 : check int input + CASE 2 : check real input + CASE 3 : check text input + END SELECT; + IF NOT last conversion ok THEN input error no := wrong type FI; + input error no = 0 + + . check int input : + IF input value <> "" + THEN disable stop; + INT VAR help int value; + help int value := int (input value); + IF is error CAND error code = int overflow + THEN clear error; + input error no := overflow; + FI; + enable stop; + FI; + + . check real input : + IF input value <> "" + THEN disable stop; + REAL VAR help real value; + help real value := val (input value); + IF is error CAND (error code = real overflow + OR error code = int overflow) (* <-- Aufgrund eines Fehlers in 'real' *) + THEN clear error; + input error no := overflow; + FI; + enable stop; + FI; + + . check text input : + (* IF input value = "" THEN input error no := wrong type FI; *) + IF NOT is quoted string CAND quote found + THEN input error no := wrong type + FI; + + . is quoted string : + first quote found CAND last quote found + + . last quote found : + (input value SUB LENGTH input value) = quote + + . quote found : + pos (input value, quote) > 0 + +END PROC check input; + + +PROC assign input (INT VAR int value) : + + get next input value; + int value := int (input value); + +END PROC assign input; + +PROC assign input (REAL VAR real value) : + + get next input value; + real value := val (input value); + +END PROC assign input; + +PROC assign input (TEXT VAR string value) : + + get next input value; + input value := compress (input value); + IF first quote found + THEN string value := subtext (input value, 2, LENGTH input value -1) + ELSE string value := input value + FI; + +END PROC assign input; + +PROC assign input line (TEXT VAR string line) : + + string line := input line; + +END PROC assign input line; + + +PROC get next input value : (* F27/rr *) + + IF input line pos > LENGTH input line + THEN input value := ""; + input error no := insufficient data; + ELSE IF next non blank char = quote + THEN get quoted string + ELSE get unquoted string + FI; + FI; + + . next non blank char : + INT CONST next non blank char pos := pos (input line, ""33"", ""255"", input line pos + 1); + input line SUB next non blank char pos + + . get quoted string : + INT CONST quote pos := pos (input line, quote, next non blank char pos + 1); + IF quote pos = 0 + THEN input value := subtext (input line, next non blank char pos); + input line pos := LENGTH input line + 1; + input error no := wrong type; + ELSE input value := subtext (input line, next non blank char pos, quote pos); + input line pos := pos (input line, ""33"", ""255"", quote pos + 1); + IF input line pos = 0 + THEN input line pos := LENGTH input line + 1; + ELIF (input line SUB input line pos) <> comma + THEN input error no := wrong type; + input line pos DECR 1; + FI; + FI; + + . get unquoted string : + INT VAR comma pos := pos (input line, comma, input line pos + 1); + IF comma pos = 0 + THEN input value := subtext (input line, input line pos + 1); + input line pos := LENGTH input line + 1; + ELSE input value := subtext (input line, input line pos + 1, comma pos - 1); + input line pos := comma pos; + FI; + +END PROC get next input value; + + +BOOL PROC input ok: + + IF input line pos <= LENGTH input line + THEN input error no := too much data FI; + input line pos := 0; + input error no = 0 + +END PROC input ok; + +BOOL PROC input eof: input line = "" END PROC input eof; + + +END PACKET basic input; + +PACKET basic std using io (* Autor: R. Ruland *) + (* Stand: 26.10.87/rr/mo *) + + DEFINES init rnd: + + +PROC init rnd: + + REAL VAR init; + REP read input (TRUE, "Startwert des Zufallszahlengenerators ? ", FALSE); + UNTIL check input (2) CAND input ok PER; (* F24/rr *) + assign input (init); + init rnd (init); + +END PROC init rnd; + + +END PACKET basic std using io; + diff --git a/lang/basic/1.8.7/src/eumel coder 1.8.1 b/lang/basic/1.8.7/src/eumel coder 1.8.1 new file mode 120000 index 0000000..5fead18 --- /dev/null +++ b/lang/basic/1.8.7/src/eumel coder 1.8.1 @@ -0,0 +1 @@ +../../../../system/eumel-coder/1.8.1/src/eumel coder 1.8.1
\ No newline at end of file diff --git a/lang/basic/1.8.7/src/eumel0 codes b/lang/basic/1.8.7/src/eumel0 codes Binary files differnew file mode 100644 index 0000000..226014c --- /dev/null +++ b/lang/basic/1.8.7/src/eumel0 codes diff --git a/lang/basic/1.8.7/src/gen.BASIC b/lang/basic/1.8.7/src/gen.BASIC new file mode 100644 index 0000000..9690ae6 --- /dev/null +++ b/lang/basic/1.8.7/src/gen.BASIC @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* Generatorprogramm zur Installation des EUMEL-BASIC-Systems *) +(* *) +(* Autor: Heiko Indenbirken *) +(* Überarbeitet von: Michael Overdick *) +(* *) +(* Stand: 27.08.1987 *) +(* *) +(**************************************************************************) + +LET coder name = "eumel coder 1.8.1"; + +show headline; +from archive ("BASIC.1", (coder name & "eumel0 codes") - all); +from archive ("BASIC.2", + ("BASIC.Runtime" & "BASIC.Administration" & "BASIC.Compiler") - all); +set status; +insert ("eumel coder 1.8.1"); +insert ("BASIC.Runtime"); +insert ("BASIC.Administration"); +insert ("BASIC.Compiler"); +forget (coder name & "BASIC.Runtime" + & "BASIC.Administration" & "BASIC.Compiler" & "gen.BASIC"); +restore status; +show end . + +show headline: + page; + putline (" "15"Einrichten des EUMEL-BASIC-Systems "14""); + line . + +set status: + BOOL VAR old check := check, + old warnings := warnings, + old command dialogue := command dialogue; + check off; + warnings off; + command dialogue (FALSE). + +restore status: + IF old check THEN do ("check on") ELSE do ("check off") FI; + IF old warnings THEN warnings on FI; + command dialogue (old command dialogue). + +show end: + line (2); + putline (" "15"BASIC-System installiert "14""); + line . + +PROC from archive (TEXT CONST name, THESAURUS CONST files): + IF highest entry (files) > 0 + THEN ask for archive; + archive (name); + fetch (files, archive); + release (archive); + putline ("Archiv abgemeldet !") + FI . + +ask for archive: + line; + IF no ("Archiv """ + name + """ eingelegt") + THEN errorstop ("Archive nicht bereit") FI . + +END PROC from archive; + +THESAURUS OP & (TEXT CONST left, right): + THESAURUS VAR result := empty thesaurus; + insert (result, left); + insert (result, right); + result +END OP &; + +THESAURUS OP & (THESAURUS CONST left, TEXT CONST right): + THESAURUS VAR result := left; + insert (result, right); + result +END OP &; + + diff --git a/lang/dynamo/1.8.7/doc/dynamo handbuch b/lang/dynamo/1.8.7/doc/dynamo handbuch new file mode 100644 index 0000000..4012973 --- /dev/null +++ b/lang/dynamo/1.8.7/doc/dynamo handbuch @@ -0,0 +1,1826 @@ +#block##pageblock##page (2)##setcount (1)##count per page# +#head# +#center#DYNAMO-Compiler +#center#____________________________________________________________ + +#end# +#bottom odd# +#center#____________________________________________________________ +GMD #right#DYNAMO - % +#end# +#bottom even# +#center#____________________________________________________________ +DYNAMO - % #right#GMD +#end# + +#ib#1. Einleitung#ie# + + + +Diese Handbuch beschreibt die Funktion des EUMEL-DYNAMO-Compilers in der +Version 3.3+ und seine Einschränkungen oder Änderungen gegenüber dem +DYNAMO-Sprachstandard. In keiner Weise kann diese Beschreibung eine Einfüh +rung in die Programmiersprache DYNAMO ersetzen! + +Die beschriebene Compilerversion enthält nun auch ein Modul zur Unterstützung von +hochauflösender Grafik durch die häufig in IBM-PC/AT-Kompatiblen eingesetzte +CGA-Grafikkarte. Dennoch ist es einfach möglich, diesen Grafikmodus auszuschal +ten, und somit die alte, zeichenorientierte Grafik weiter zu verwenden. + +Der DYNAMO-Compiler wurde 1983 von Robert Keil und Torsten Fröhlich (Helm +holtz-Gymnasium, Bonn) im Rahmen des MIKROS-Projektes am Informatik-Kolleg +der GMD entwickelt. Für Spezifikation und Betreuung der Entwicklung war Dr. Diether +Craemer verantwortlich, software-technische Unterstützung kam von Prof. John +Henize, Dr. Peter Heyderhoff, Rudolf Legde und Dipl.- Math. Lothar Oppor. Die +Grafik wurde von D.Giffeler beigesteuert. + + + + +#ib#1.1. Referenzliteratur#ie# + + + + + [1] Craemer, Diether + "Mathematisches Modellieren dynamischer Vorgänge" + e. Einf. in die Programmiersprache DYNAMO + Stuttgart, Teuber, 1985 + ISBN 3-519-02477-2 + + [2] Craemer, Diether + "Fluß und Zustand - Simulation dynamischer Vorgänge in DYNAMO" + in: LOGIN 5 (1985), Heft 1, S. 20-23 + + [3] Pugh, Alexander L. + "DYNAMO II User's Manual" + Cambridge, London 1973: MIT-Press + ISBN 0-262-66018-0 +#page# + +#ib#1.2. Die Programmiersprache DYNAMO#ie# + + + +DYNAMO wurde von einer Gruppe um Jay FORRESTER am Massachusetts Institute +of Technology (MIT) um 1960 entwickelt. Die Sprache basiert auf der #on ("i")# System +Dynamic#off ("i")# von FORRESTER. + +In DYNAMO (#on ("u")##on ("b")#Dyna#off ("b")##off ("u")#mic #on ("u")##on ("b")#Mo#off ("b")##off ("u")#delling Language) können Systeme, in denen Veränderun +gen kontinuierlich geschehen, modelliert und simuliert werden. + +Kontinuierliche Veränderungen von Größen werden über deren Veränderungsrate im +Wesentlichen nach folgender Gleichung berechnet + +Größe jetzt = Größe früher + DT * Veränderungsrate, + +dabei ist DT die Länge des Zeitintervalls von "früher" bis "jetzt". + +Außer diesen Gleichungen für Größen braucht man Gleichungen für die Verände +rungsraten, für Hilfsgrößen, zur Initialisierung von Größen, zur Definition von Konstan +ten und Tabellen, zu Angaben von Simulationsläufen und zur Wiedergabe von Ergeb +nissen in Zahlentabellen oder Diagrammen. + +Alle diese Gleichungen können einfach in der Form, wie man sie aus dem Mathema +tik-Unterricht der Sekundarstufe kennt, hingeschrieben werden, ohne sich Gedanken +über den Ablauf des Programms machen zu müssen. + +#on ("b")# +DYNAMO ist also eine einfache funktional-applikative, nicht-prozedurale Sprache.#off ("b")# + +Das macht ihren Reiz und ihre Leistungsfähigkeit aus, die zur Formulierung der be +kannten Weltmodelle von FORRESTER, MEADOWS ("Die Grenzen des Wachstums"), +PESTEL, MESAROVIC u.a. in dieser Sprache führten. + +Anwendungsgebiete der Sprache sind ökologische, gesellschaftliche, wirtschaftliche +und technische Systeme, deren dynamisches Verhalten der Modellbildner nachbilden +und studieren möchte. + +Im Allgemeinen verfolgt der Modellbildner mit seinem Modell einen Zweck (Verhaltens +änderung des nachgebildeten Systems), so daß auch neben gesicherten Fakten die +Wertvorstellungen des Modellbildners in das Modell eingehen. + + + + +#ib#1.3 Kurz-Einführung in die DYNAMO- +Schreibweise#ie# + + + +Die System Dynamic Methode benutzt als Analogie-Bild den Archetyp des Flusses: + + - Wasser fließt durch das Flußbett, kann in Seen gestaut und in der Ge + schwindigkeit durch Schleusen und Wehre reguliert werden. + + - Analog dazu "fließt" Geld auf dem Überweisungsweg, wird in Konten gestaut, + und die Liquidität kann durch Zinssätze reguliert werden. + + - Gedanken "fließen" auf Nervenbahnen, werden im Gehirn gespeichert, und + Gedankenströme werden über Synapsen reguliert. + + - Autos "fließen" über Straßen, werden auf Parkplätzen gestaut, und der Ver + kehrsfluß wird über Ampeln reguliert. + + - Menschen "fließen" über Wanderwege, halten sich in Wohnorten auf, und die + Bevölkerungsdynamik wird durch ein komplexes, rückgekoppeltes Zusammen + spiel von Ein- und Auswanderungsraten sowie Geburts- und Sterberaten + reguliert. + +Am letzten Beispiel wird deutlich, daß sich ein soziales Phänomen nur im Zusam +menwirken vieler netzartig miteinander verbundener Variablen beschreiben läßt (wenn +überhaupt). + +Solange jedoch einigen Variablen ZUSTANDS-CHARAKTER ("Wasserstand") und +anderen VERÄNDERUNGS-CHARAKTER ("Flußgeschwindigkeit") zugeordnet +werden kann, können die Größen für Berechnungen folgender Art verwendet werden: + + + Wasserstand jetzt = Wasserstand früher + vergangene Zeit * + (Zuflußrate - Abflußrate) + + +analog: + + Bevölkerung jetzt = Bevölkerung früher + vergangene Zeit * + (Geburtsrate - Sterberate) + + +Diese Schreibweise kann praktisch so in ein Computerprogramm übernommen wer +den. Mit geringfügigen Änderungen handelt es sich bei diesen Gleichungen schon um +gültige Zeilen in der Programmiersprache DYNAMO. + +In DYNAMO wird er Zeitpunkt "jetzt" durch das Anhängsel .K, der Zeitpunkt "früher" +durch das Anhängsel .J, die Zeitspanne von jetzt bis später durch das Anhängsel .KL, +die Zeitspanne von früher bis jetzt durch das Anhänsel .JK und die vergangene Zeit +mit DT (wie "Delta Tempus": Zeitdifferenz) bezeichnet. Die Variablen mit Zustands- +Charakter heißen LEVELS (Niveaus) und die Veränderungs-Charakter heißen RATES +(Veränderungsraten, Geschwindigkeiten). Die entsprechenden Gleichungen werden mit +L bzw. R gekennzeichnet. Es gib weitere Kennzeichnungen: + + C für Konstantendefinition (constant) + T für Tabellendefintion (table) + A für Hilfsgrößen (auxiliaries) + N für Anfangswerte (initial) + X für Folgezeile (extension) + PRINT für Ausgabe von Zahlen + PLOT für Ausgabe von Diagrammen + +Ein einfaches Bevölkerungsmodell könnte z.B. so geschriben werden: + + + L BEVÖLKERUNG.K=BEVÖLKERUNG.J+DT*(GEBURTENRATE.JK + X -STERBERATE.JK) + R STERBERATE.KL=5 + R GEBURTENRATE.KL=20 + N BEVÖLKERUNG=1000 + C DT=1 (jedes Jahr wird neu berechnet) + C LENGTH=60 (60 Jahre werden simuliert) + PRINT BEVÖLKERUNG + + +Für eine tiefere Einführung in DYNAMO sollte man die Referenzliteratur zu Rate +ziehen. + + + + +#ib#1.4 Eine erste, kleine Sitzung mit dem +DYNAMO-System#ie# + + + +Wir gehen davon aus, daß das DYNAMO-System in ihrer Task generiert worden ist +(siehe 2.). + + 1. Tippen Sie das obrige Programm mittels des EUMEL-Editors ab. + + 2. Verlassen Sie den Editor mit <ESC><q> und starten Sie den DYNAMO- + Compiler durch die Eingabe des Befehls "dynamo". + + 3. Nach erfolgreichem Übersetzen sollte Ihnen nun das DYNAMO-Runtime- + System zur Verfügung stehen. Durch den Befehl 'run' wird das Programm aus + geführt und Sie erhalten eine Zahlenkolonne, die die Entwicklung der Bevöl + kerung in den zu untersuchenden 60 Jahren angibt. Falls Ihnen beim Abtippen + des Programms Fehler unterlaufen sein sollten, so kann das Programm nicht + fehlerfrei übersetzt werden. Fehlermeldunggen zur Compile-Zeit des + DYNAMO-Compilers werden im Paralleleditor angezeigt; das Programm kann + im oberen der beiden Editorfenster (in diesem befinden Sie sich auch nach + Fehlern) korrigiert werden. Danach können Sie erneut wie nach Punkt 2 ver + fahren. +#page# + + + +#ib#2. Generierung des DYNAMO-Compilers#ie# + + + +Der DYNAMO-Compiler, seine Funktionen und die Beispielprogramme werden auf +zwei Archiv-Disketten a#b#' 360 KB ausgeliefert. + +Zum Generieren des DYNAMO-Systems legen Sie bitte die erste Diskette in das +Dikettenlaufwerk Ihres Rechners und durch folgende Kommandozeile lesen Sie den +Generator vom Archiv und starten ihn: + + + archive ("dynamo"); fetch ("dyn.inserter", archive); run + + +Danach holt der Generator alle benötigten Dateien vom eingelegten Archiv bzw. von +dem zweiten Archiv (nachdem er Sie zum Wechseln der Diskette aufgefordert hat). +Anschließend wird der DYNAMO-Compiler insertiert. Am Ende der Generierung +werden Sie gefragt werden, ob Sie den Compiler mit Grafik#u##count ("Grafik")##e# oder ohne benutzen +wollen. Nach der Meldung "dynamo system generiert" können Sie den Compiler#foot# +#u##value ("Grafik")##e# Es kann z.Zt. nur eine CGA-Grafikkarte betrieben werden +#end# +nutzen. +#page# + + + +#ib#3. Der EUMEL-DYNAMO-Compiler#ie# + + + +Der im EUMEL-System implementierte DYNAMO-Compiler ist ein 2-Pass- +Compiler, der die DYNAMO-Programme zunächst in ELAN übersetzt. Der Vorteil +dieser Methode besteht darin, daß es möglich ist, übersetzte Programme unabhängig +vom DYNAMO-Compiler zur Ausführung bringen zu können. + +Die Notation der im folgenden aufgeführten ELAN-Prozeduren des Compilers ent +spricht der in den EUMEL-Handbüchern üblichen Prozedurkopf-Schreibweise. + +Als Beispiel: + + + dynamo ("dyn.grasshasenfuchs") + + +ein Beispiel für den Aufruf der Prozedur mit der Prozedurkopf-Schreibweise + + PROC dynamo (TEXT CONST filename) + +auf der Kommando-Ebene des Betriebssystems EUMEL. + +Der Prozedur 'dynamo' wird beim Aufruf der Dateiname (TEXT) 'filename' übergeben +und dadurch der Compiler auf die Datei mit dem Namen 'filename' angewendet. + + + + +#ib#3.1. Benutzung des DYNAMO-Compiler#ie# + + + +Um ein DYNAMO-Programm zu Übersetzen, gibt es grundsätzlich zwei Möglichkei +ten. Erst einmal kann man ein DYNAMO-Programm in ein ELAN-Programm um +wandeln, jedoch ohne es dabei zur Ausführung zu bringen. Dieses ELAN-Programm +kann man nun unabhängig vom eingentlichen Compiler starten. Die zweite, wohl öfter +angewendete Methode ist, ein DYNAMO-Programm in ein ELAN-Programm zu +compilieren, wobei es danach direkt ausgeführt wird. Ob danach ein ELAN- +Programm zur Verfügung stehen soll, kann der Benutzer selbst entscheiden. + + +PROC dynamo + + Zweck: Aufruf des DYNAMO-Compilers mit 'quelldatei' = 'last param', d.h. das + zu übersetzende Programm steht in der zuletzt bearbeiteten Datei. + + +PROC dynamo (TEXT CONST quelldatei) + + Zweck: Ruft den DYNAMO-Compiler für die Datei 'quelldatei' auf. Anmerkung: + Gleichbedeutend mit 'dynamo (quelltext, quelltext + ".elan", TRUE)', s. + nächste Prozedur. + + Beispiel: + + + dynamo ("dyn.grashasenfuchs") + + + Der DYNAMO-Compiler wird auf die Datei "dyn.grashasenfuchs" ange + wendet. + + +PROC dynamo (TEXT CONST quelldatei, zieldatei, + BOOL CONST pass2 ausfuehren) + + Zweck: Diese Prozedur startet den DYNAMO-Compiler. 'quelldatei' gibt den + Namen der Datei an, in welcher der DYNAMO-Quelltext enthalten ist, + 'zieldatei' ist der Name der Datei, die das erzeugte ELAN-Programm + beinhalten soll. Wenn 'pass2 ausfuehren' = TRUE, dann wird dieses auch + durch den ELAN-Compiler weiterverarbeitet (das Programm wird zur + Ausführung gebracht). + + Beispiel: + + + dynamo ("dyn.grashasenfuchs", + "grashasenfuchs.elanprogramm", FALSE) + + + Im obigen Beispiel wird der in der Datei "dyn.grashasenfuchs" enthaltene + DYNAMO-Quelltext in die Datei "grashasenfuchs.elanprogramm" als + ELAN-Programm geschrieben. Das ELAN-Programm wird nicht ausge + führt. + + +PROC erase (BOOL CONST erase option) + + Zweck: Wenn 'erase option' = TRUE, so werden die erzeugten ELAN-Programme + nach Beendigung der Ausführung gelöscht, bei 'erase option' = FALSE + bleiben sie erhalten (Voreinstellung: 'erase option' = FALSE). + + +PROC error listing (TEXT CONST fehlerdatei) + + Zweck: Falls gewünscht ist, die Fehlermeldungen, die ggf. beim Übersetzen ein + treten, auch in eine Datei zu schreiben, so können Sie hier unter 'fehler + datei' einen Dateinamen angeben. Bei der Angabe von "" wird die Umlei + tung in die Datei ausgeschaltet werden (Voreingestellt ist 'fehlerdatei' = + ""). + + +PROC graphic (BOOL CONST graphic option) + + Zweck: Mit dieser Prozedur läßt sich einstellen, ob bei der DYNAMO-Anweisung + PLOT die hochauflösende Grafik ('graphic option' = TRUE) oder die zei + chenorientierte Grafik ('grafik option' = FALSE) verwendet werden soll. Die + Voreinstellung wird bei der Installation des Compilers erfragt. + + +PROC protokoll (BOOL CONST protokoll option) + + Zweck: Bei 'protokoll option' = TRUE werden alle Textausgaben, die bei der + Laufzeit des DYNAMO-Programmes auftreten, nicht nur auf dem Bild + schirm dargestellt, sondern auch in eine Datei mit dem Namen "dyn.out" + protokolliert (voreingestellt ist 'protokoll option' = FALSE). Die Datei + "dyn.out" enthält auch Seitenvorschubbefehle ('\#page\#') und sollte nur mit + einem EUMEL-Printer ausgedruckt werden. + + + + +#ib#3.2. Abweichungen gegenüber dem + Sprachstandard#ie# + + + + - Die Länge der Namen ist nicht auf 7 Zeichen festgelegt, sondern praktisch be + liebig (32000). Dies ist eine Erweiterung; wer seine Programme auch auf ande + ren DYNAMO-Compilern laufen lassen will, sollte sich aber auf 7 Zeichen be + schränken. + + - Zahlen werden intern mit einer Mantisse von 13 Stellen abgespeichert, von denen + nur die ersten 7 bei der Ausgabe dargestellt werden. Die größte darstellbare Zahl + ist daher 9.999999999999e126. + + - Die maximale Anzahl der Gleichungen ist auf 950 festgelegt. + + - Der Compiler akzeptiert aus Gründen der besseren Lesbarkeit auch Programme, + die in Kleinschrift geschrieben sind. Dabei ist es sinnvoll, die Quellprogramme + konsistent zu halten (d.h. Groß- und Kleinschrift nicht zu vermischen). Man + sollte grundsätzlich Kleinschrift vorziehen, da diese vom Compiler auch effizienter + verarbeitet werden kann. + + - Quellprogramme dürfen eine beliebige Zahl von Leerzeilen enthalten. X - Befeh + le (Fortschreibungszeilen) werden davon nicht beeinflußt. + + - In der augenblicklichen Version 3.3 des Compilers gelten folgende Einschränkun + gen : + + 1. Bei der Verarbeitung von Array-Gleichungen werden Compilerseitig keine + Semantik-Überprüfungen auf eventuell unzureichende Initialisierung oder + Überlappung (d.h. mehrfaches Setzen desselben Elements) durchgeführt. + Defaultmäßig bekommen alle Elemente einer Array-Gleichung bei der Initiali + sierung den Wert '0.0' zugewiesen. + + 2. Die maximale Größe von Tables und Array-Gleichungen ist durch Verwen + dung des Vector-Pakets auf 4000 Elemente festgelegt. Da pro Table-Ele + ment aber zur Zeit eine Zeile im Zielprogramm generiert wird, sollte man dies + besser nicht ausnutzen. + + 3. Supplementary-Gleichungen werden aus Kompatibilitäts-Gründen korrekt + übersetzt, aber sonst wie Auxiliary-Gleichungen behandelt. + + 4. Print ('prtper')- und Plotperiode ('pltper') werden nur als Konstanten verarbei + tet. Falls Gleichungen für 'prtper' oder 'pltper' angegeben werden, so bewirken + diese keine Veränderung. + + 5. Array-Gleichungen dürfen nicht mehr als eine Dimension besitzen. + + 6. Für Gleichungen, die Makro-Aufrufe enthalten, sollten Initialisierungs (N)- + Gleichungen angegeben werden. + + + +#ib#3.3. Das DYNAMO Runtime-System#ie# + + + +Nach erfolgreicher Übersetzung wird vom Zielprogramm das Runtime-System aufge +rufen. In diesem Modus (das DYNAMO-Runtime-System meldet sich mit "dynamo +runtime system :") ist es möglich, Konstanten zu ändern und DynamoProgramme zur +Ausführung zu bringen. + +Im DYNAMO-Runtime-System stehen folgende Kommandos zur Verfügung (näheres +zur Notation siehe Kapitel 4, S. #to page ("Anweisungen und Funktionen")#). + + + run + + Zweck: Ausführen des übersetzten Programms + + + run <name> + + Zweck: Ausführen des übersetzten Programms und retten des Konstantendaten + raums in des Datenraum mit dem Namen "<name>.const". Existiert der + Datenraum bereits, werden die Konstanten aus dem Datenraum in den + Lauf übernommen. Somit ermöglicht der Compiler, Konstantenwerte aus + einem früheren Lauf wieder zu verwenden. + + + c <Konstantenname>=Wert [/<Konstantenname>=Wert [...]] + + Zweck: Änderung einer oder mehrerer Konstanten + + + ? + + Zweck: Anzeigen der Konstanten und ihrer Werte + + + quit + + Zweck: Verlassen des Runtime-Systems + + + help + + Zweck: Zeigt eine kurze Erklärung + + +Bei PRINT- und PLOT-Ausgaben sind folgende Kommandos möglich: + + + Nächster Bildschirm + o (Off), keine Unterbrechung der Ausgabe (nicht möglich bei hochauflösen + der Grafik) + e (End), Zurück zum Runtime System + p Phasendiagramm (nur bei hochauflösender Grafik möglich) + + + +#ib#3.4. Fehlermeldungen des + DYNAMO-Compilers#ie# + + + +Falls der Compiler einen Fehler im DYNAMO-Programm entdeckt, gibt er eine Feh +lermeldung nach dem folgenden Muster aus: +"Fehler in Zeile <zeilennummer> bei >> <symbol> << : <fehlertext>. + +Im folgenden sind alle Fehlermeldungen und Möglichkeiten zur Abhilfe aufgelistet, +sofern diese nicht klar ersichtlich sind: + + 1 GLEICHUNG DOPPELT DEFINIERT + + 2 DOPPELTE INITIALISIERUNG + + 3 FALSCHER ZEILENTYP + -> Erlaubt sind : a, c, l, n, r, s, print, plot, note, spec, *, x, macro, mend, + for, noise, run. + + 4 VERSCHACHTELTE MAKRO-DEFINITION + -> 'mend' - Befehl fehlt. + + 5 MAKRO-NAME ERWARTET + + 6 '(' ERWARTET + + 7 FORMALER PARAMETER ERWARTET + + 8 ')' NACH PARAMETERLISTE ERWARTET + + 9 BEI AUXILIARIES NUR SUBSKRIPTION MIT '.K' ERLAUBT + +10 BEI KONSTANTEN-DEFINITION NAME ERWARTET + +11 BEI LEVELS NUR SUBSKRIPTION MIT '.K' ERLAUBT + +12 BEI RATES NUR SUBSKRIPTTION MIT '.KL' ERLAUBT + +13 BEI TABLE-DEFINITIONEN KEINE SUBSKRIPTION ERLAUBT + +14 X - BEFEHL HIER NICHT ERLAUBT + +15 BEI FOR-DEFINITION NAME ERWARTET + +16 '=' NACH FOR-VARIABLE ERWARTET + +17 BEREICHSANGABE ERWARTET + +18 ',' ERWARTET + +19 LOKALE GLEICHUNG NUR IN MAKRO ERLAUBT + +20 BEI DEFINITION NAME ERWARTET + +21 '=' ERWARTET + +22 INDEX NICHT KORREKT + -> Als Index ist nur erlaubt : <for variable> !, + <add op> <ganze zahl>!. + <add op> ::= "+"; "-". + +23 ')' NACH INDIZIERUNG ERWARTET + +24 PRTPER NICHT DEFINIERT + -> Wenn das Programm einen Print-Befehl enthält, muß 'prtper' (Printperiode) + als Konstante definiert werden. + +25 PLTPER NICHT DEFINIERT + -> Wenn das Programm einen Plot-Befehl enthält, muß 'pltper' (Plotperiode) + als Konstante definiert werden. + +26 '/' ODER ',' BEI PLOT ERWARTET + +27 NAME ALS PLOTPARAMETER ERWARTET + +28 DOPPELTE SCALE - ANGABE IN EINER GRUPPE + -> Wenn mehrere Plotparameter mit ',' getrennt werden (also die gleiche Ska + lierung erhalten), dürfen nicht mehrere feste Skalierungen angegeben wer + den. + +29 ERSTE SCALE - ANGABE ERWARTET + +30 ZWEITE SCALE - ANGABE ERWARTET + +31 ')' NACH SCALE - ANGABE FEHLT + +32 PRINTPARAMETER NICHT DEFINIERT + +33 PRINTPARAMETER ERWARTET + +34 TIME DARF NUR INITIALISIERT WERDEN + +35 DT NICHT DEFINIERT + +36 LENGTH NICHT DEFINIERT + +37 BEI KONSTANTEN - DEFINITION ZAHL ERWARTET + +38 BEI INITIALISIERUNG KONSTANTE ERWARTET + +39 LEVELS MUESSEN INITIALISIERT WERDEN + +40 KONSTANTE BEI TABLE ERWARTET + +41 '/' ODER "," ERWARTET + +42 TABLE - DEFINITION OHNE BENUTZUNG + +43 SIMULTANE GLEICHUNGEN + -> Bei dem Versuch, A, R, oder N - Gleichungen zu sortieren, trat eine + direkte oder indirekte Rekursion auf. + +44 FAKTOR ERWARTET + -> Erwartet : <zahl>; + <funktions aufruf>; + <macro aufruf>; + <gleichungs name>; + '(', <ausdruck>, ')'; + <monadischer operator>, <faktor>. + <monadischer operator> ::= '+'; '-'. + +45 TIME MUSS MIT '.J' ODER '.K' SUBSKRIBIERT WERDEN + +46 SYMBOL NICHT DEFINIERT + +47 FUNKTION NICHT DEFINIERT + +48 UNZULAESSIGE INDIZIERUNG + -> Die Indices auf beiden Seiten der Gleichung müssen immer gleich sein. + +49 FALSCHE PARAMETERANZAHL + +50 FALSCHES TRENNSYMBOL ZWISCHEN PARAMETERN + +51 ALS PARAMETER TABLE ERWARTET + +52 FALSCHER PARAMETER IN TABLEFUNKTION + +53 ZU VIELE AKTUELLE PARAMETER + +54 ')' NACH MAKROAUFRUF FEHLT + +55 REKURSIVER MAKROAUFRUF + +56 BEI N - GLEICHUNG KEINE SUBSKRIPTION ERLAUBT + +57 FALSCHE SUBSKRIPTION IN AUXILIARY - GLEICHUNG + +58 ')' ERWARTET + +59 FALSCHE SUBSKRIPTION IN LEVEL - GLEICHUNG + +60 FALSCHE SUBSKRIPTION IN RATE - GLEICHUNG + +61 FOR - VARIABLE NICHT DEFINIERT + -> Eine FOR - Variable muß vor der ersten Benutzung definiert werden. + +62 KONSTANTE ERWARTET + +63 FALSCHES REAL - FORMAT + -> Exponent fehlt + +64 GLOBALE GLEICHUNG IN MACRO NICHT ERLAUBT + +65 DOPPELTE DEFINITION BEI MEHRFACHEM MAKROAFRUF + +66 ALS NOISE - PARAMETER ZAHL ERWARTET +#page# + +#ib#4. Anweisungen und Funktionen des + EUMEL-DYNAMO-Compilers#ie# +#goal page ("Anweisungen und Funktionen")# + + +Dieses Kapitel gibt eine alphabetische Übersicht über die im EUMEL-DYNAMO- +Compiler realisierten Anweisungen und Funktionen (wertliefernde Algorithmen). + +Die Beschreibung der Anweisungen und Funktionen ist nach der DYNAMO- +Syntaxregel angegeben, wobei folgende Zeichen mit besonderer Bedeutung verwendet +werden: + + [] optionale Angabe + [...] beliebig häufige Wiederholung der letzten optionalen Angabe + < > in spitzen Klammern stehende Namen sind Variablen- bzw. Konstan + tennamen + <Name> steht für einen beliebigen Bezeichner gemäß der DYNAMO-Syntax + <Zahl> bezeichnet einen beliebigen Wert (also auch eine Ausdruck) + {} Alternative Angabe + + X DYNAMO Anweisung, kennzeichnet eine Fortsetzungsszeile der + vorhergegangenen Anweiung (S. #to page ("X")#) + +Alle Anweisungen und Funktionen werden nach dem gleichen Schema dargestellt: + + + +Funktionsname#right#Typ (Funkt. oder Anweisung) + + +Zweck: Schlagwort zur Wirkung + +Format: Beschreibung des Formates (spezielle Zeichen s.o.) + +Erklärung: kurze Beschreibung der Anweisung/Funktion + +Beispiel: Anwendung der Anweisung/Funktion + +Programm: Beispielprogramm, in welchem die Anweisung/Funktion angewendet wird. + +Referenz: Verweis auf ähnliche oder äquivalente Anweisungen/Funktionen im + Format '<Funktions- bzw. Anweisungsname>, Seitennummer'. + + +Eine oder mehrere dieser Felder können fehlen (z.B. wenn es keine Referenz oder +kein Beispielprogramm gibt). +#page# + + + +#ib#4.1. Übersicht über die Anweisungen und + Funktionen#ie# + + + +#goal page ("A")##ib (2)#A#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Auxiliary-Gleichung (A-Gleichung, Hilfsgleichung) + +Format: A <Auxiliary-Name>.K=<Ausdruck>#u##count ("Ausdruck")##e# +#foot# +#u##value ("Ausdruck")##e# genaueres über die Definition eines Ausdruckes siehe [1], S. 93 +#end# + +Erklärung: Mit Hilfe von Auxiliary-Gleichungen werden Level- und Hilfsgrößen + (Auxiliaries) zum selben Zeitpunkt verknüpft. + +Beispiel: A JM.K=MM.K/MEJ + +Programm: "dyn.workfluc" + + + +#ib (2)#ABS#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Absolutbetrag + +Format: ABS(<Zahl>) + +Erklärung: Liefert den Absolutbetrag + + + IF <Zahl> >= 0 THEN + <Zahl> + ELSE + - <Zahl> + END IF + +Beispiel: N X=ABS(A*2.0) + + + +#goal page ("ARCTAN")#ARCTAN#on ("i")##right#Funktion#off ("i")# + + +Zweck: Berechnung der trigonometrischen Funktion Arcustangens + +Format: ARCTAN(<Zahl>) + +Erklärung: Berechnet den Arcustangens von <Zahl>; Ergebnis im Bogenmaß. + +Beispiel: N X=ARCTAN(TAN(1.3)) (X = 1.3) + + +Referenz: COSD, S. #to page ("COSD")# + SIN, S. #to page ("SIN")# + SIND, S. #to page ("SIND")# + TAN, S. #to page ("TAN")# + TAND, S. #to page ("TAND")# + ARCTAND, S. #to page ("ARCTAN")# + COS, S. #to page ("COS")# + + + +#goal page ("ARCTAND")##ib (2)#ARCTAND#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Berechnung der trigonometrischen Funktion Arcustangens + +Format: ARCTAND(<Zahl>) + +Erklärung: Berechnet den Arcustangens von <Zahl>; Ergebnis im Gradmaß + +Beispiel: N X=ARCTAND(TAND(45.0)) (X = 45.0) + + +Referenz: COSD, S. #to page ("COSD")# + SIN, S. #to page ("SIN")# + SIND, S. #to page ("SIND")# + TAN, S. #to page ("TAN")# + TAND, S. #to page ("TAND")# + COS, S. #to page ("COS")# + ARCTAN, S. #to page ("ARCTAND")# + + + +#goalpage ("C")##ib (2)#C#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Konstantendefinition + +Format: C <Name>=<Zahl> + +Erklärung: Werte, die während eines Simulationslaufes gleich bleiben, können durch + die Konstantendefintion benannt werden (s. auch 'c' im Runtime- + System). + +Beispiel: C POPI=30.3 + +Programm: "dyn.wohnen" + + + +#goal page ("CLIP")##ib (2)#CLIP#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Wert nach Bedingung + +Format: CLIP(<Zahl1>,<Zahl2>,<Zahl3>,<Zahl4>) + +Erklärung: Liefert den Wert des ersten Argumentes, wenn das dritte Argument + größer oder gleich dem vierten Argument ist. Andernfalls wird der Wert + des zweiten Argumentes geliefert. + + + IF <Zahl3> >= <Zahl4> THEN + <Zahl1> + ELSE + <Zahl2> + END IF + +Beispiel: N X=CLIP(1.0,2.0,3.0,4.0) (X = 2.0) + + +Programm: "dyn.welt/forrester" + +Referenz: FIFGE, S. #to page ("FIFGE")# (äquivalente Funktion) + + + +#goalpage ("COS")#COS#on ("i")##right#Funktion#off ("i")# + + +Zweck: Berechnung der trigonometrischen Funktion Cosinus + +Format: COS(<Zahl>) + +Erklärung: Es wird der Cosinus des Wertes <Zahl>, welcher im Bogenmaß vorlie + gen muß, geliefert. + +Beispiel: N X=COS(1.6) + +Referenz: COSD, S. #to page ("COSD")# + SIN, S. #to page ("SIN")# + SIND, S. #to page ("SIND")# + TAN, S. #to page ("TAN")# + TAND, S. #to page ("TAND")# + ARCTAN, S. #to page ("ARCTAN")# + ARCTAND, S. #to page ("ARCTAND")# + + + +#goal page ("COSD")##ib (2)#COSD#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Berechnung der trigonometrischen Funktion Cosinus + +Format: COSD(<Zahl>) + +Erklärung: Es wird der Cosinus des Wertes <Zahl>, welcher im Gradmaß vorliegen + muß, geliefert. + +Beispiel: N X=COSD(33.5) + +Referenz: COS, S. #to page ("COS")# + SIN, S. #to page ("SIN")# + SIND, S. #to page ("SIND")# + TAN, S. #to page ("TAN")# + TAND, S. #to page ("TAND")# + ARCTAN, S. #to page ("ARCTAN")# + ARCTAND, S. #to page ("ARCTAND")# + + + +#goal page ("EXP")##ib (2)#EXP#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Exponentialfunktion zur Basis e + +Format: EXP(<Zahl>) + +Erklärung: Liefert e#u#<Zahl>#e# + +Beispiel: N X=EXP(1.0) (X = 2.71 = e) + + +Referenz: LN, S. #to page ("LN")# (Umkehrfunktion) + + + +#goal page ("FIFGE")##ib (2)#FIFGE#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Wert nach Bedingung (#on ("u")#f#off ("u")#irst #on ("u")#if#off ("u")# #on ("u")#g#off ("u")#reater or #on ("u")#e#off ("u")#qual) + +Format: FIFGE(<Zahl1>,<Zahl2>,<Zahl3>,<Zahl4>) + +Erklärung: Liefert den Wert des ersten Argumentes, wenn das dritte Argument + größer oder gleich dem vierten Argument ist. Andernfalls wird der Wert + des zweiten Argumentes geliefert. + + + IF <Zahl3> >= <Zahl4> THEN + <Zahl1> + ELSE + <Zahl2> + END IF + +Beispiel: N X=FIFGE(1.0,2.0,3.0,4.0) (X = 2.0) + + +Referenz: CLIP, S. #to page ("CLIP")# (äquivalente Funktion) + + + +#goal page ("FIFZE")##ib (2)#FIFZE#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Wert nach Bedingung (#on ("u")#f#off ("u")#irst #on ("u")#if#off ("u")# #on ("u")#ze#off ("u")#ro) + +Format: FIFZE(<Zahl1>,<Zahl2>,<Zahl3>) + +Erklärung: Wenn der Parameter <Zahl3> den Wert 0 hat, so wird <Zahl1> + geliefert, andernfalls <Zahl2> + + + IF <Zahl3> = 0 THEN + <Zahl1> + ELSE + <Zahl2> + END IF + +Beispiel: N X=FIFZE(1.0,2.0,3.0) (X = 2.0) + + +Referenz: SWITCH, S. #to page ("SWITCH")# + + + +#goal page ("FLOOR")##ib (2)#FLOOR#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Vorkommastellen + +Format: FLOOR(<Zahl>) + +Erklärung: Liefert die Vorkommastellen von <Zahl> + +Beipiel: N X=FLOOR(3.14) (X = 3.0) + + +Referenz: FRAC, S. #to page ("FRAC")# + + + +#ib (2)#FOR#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Schleifen-Definition + +Format: FOR <Name>=<Zahl1>,<Zahl2> + +Erklärung: <Name> bezeichnet eine Schleifenvariable, die von <Zahl1> bis + <Zahl2> hochgezählt wird. Somit ist es möglich, gleiche Berechnungen + für die verschiedenen Werte einer Tabelle durchzuführen. + +Beispiel: FOR BERECHNUNGSZEITRAUM=1900,2100 + + +Programm: "dyn.bev" + + + +#goal page ("FRAC")##ib (2)#FRAC#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Nachkommastellen + +Format: FRAC(<Zahl>) + +Erklärung: Liefert die Nachkommastellen von <Zahl> + +Beispiel: N X=FRAC(3.14) (X = 0.14) + + +Referenz: FLOOR, S. #to page ("FLOOR")# + + + +#goal page ("L")##ib (2)#L#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Level-Gleichung + +Format: L <Level-Name>.K=<Level-Name>.J+ + <Vergangenheitsausdruck> + +Erklärung: Die Level-Gleichung stellt einen gegenwärtigen Wert in Bezug zu + seinem Wert in der Vergangenheit und seiner Veränderungsrate in der + bis dahin vergangenen Zeit (Vergangenheitsausdruck s. [1], S. 96). + +Beispiel: L HASEN.K=CLIP(HASEN.J+DT*(HGRATE.JK + X -HSRATE.JK),0,HASEN.J,0) + +Programm: "dyn.grashasenfuchs" + + + +#goal page ("LN")##ib (2)#LN#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Logarithmus-Funktion + +Format: LN(<Zahl>) + +Erklärung: Berechnet den natürlichen Logarithmus von <Zahl> + +Beispiel: N X=LN(1.0) (X = 0.0) + + +Programm: "dyn.wasseröko" + +Referenz: LOG2, S. #to page ("LOG2")# + LOG10, S. #to page ("LOG10")# + EXP, S. #to page ("EXP")# + + + +#goal page ("LOG2")##ib (2)#LOG2#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Logarithmus-Funktion + +Format: LOG2(<Zahl>) + +Erklärung: Berechnet den Logarithmus von <Zahl> zur Basis 2 + +Beispiel: N X=LOG2(8.0) (X = 3.0) + + +Referenz: LN, S. #to page ("LN")# + LOG10, S. #to page ("LOG10")# + + + +#goal page ("LOG10")##ib (2)#LOG10#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Logarithmus-Funktion + +Format: LOG10(<Zahl>) + +Erklärung: Berechnet den Logarithmus von <Zahl> zur Basis 10 + +Beispiel: N X=LOG10(100.0) (X = 2.0) + + +Referenz: LOG2, S. #to page ("LOG2")# + LN, S. #to page ("LN")# + EXP, S. #to page ("EXP")# + + + +#goal page ("MACRO")##ib (2)#MACRO#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Macro-Definition + +Format: MACRO <Name>(<Ausdruck>[,<Ausdruck>[...]]) + +Erklärung: Durch die Verwendung der MACRO-Anweisung können Sie einer oder + mehreren DYNAMO-Gleichungen einen Namen geben (<Name>). + Macros müssen durch MEND abgeschloßen werden und dürfen #on ("u")#nicht#off ("u")# + rekursiv aufgerufen werden (vergl. Refinements in ELAN). + +Beispiel: MACRO SMOOTH(IN,DEL) + L SMOOTH.K=SMOOTH.J+DT*(IN.J-SMOOTH.J)/DEL + N SMOOTH=IN + MEND + +Programm: "dyn.mac" (diese Datei enthält alle bisherigen Makros) + +Referenz: MEND, S. #to page ("MEND")# + + + +#goal page ("MAX")##ib (2)#MAX#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Maximum zweier Größen + +Format: MAX(<Zahl1>,<Zahl2>) + +Erklärung: Liefert die größere Zahl aus <Zahl1> und <Zahl2> + + + IF <Zahl1> > <Zahl2> THEN + <Zahl1> + ELSE + <Zahl2> + END IF + +Beispiel: N X=MAX(1.0,2.0) (X = 2.0) + + +Referenz: MIN, S. #to page ("MIN")# + + + +#goal page ("MEND")##ib (2)#MEND#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Macro-Definition + +Format: MEND + +Erklärung: MEND beendet eine Macro-Definition + +Beispiel: MACRO SMOOTH(IN,DEL) + L SMOOTH.K=SMOOTH.J+DT*(IN.J-SMOOTH.J) + X /DEL + N SMOOTH=IN + MEND + +Programm: "dyn.mac" (diese Datei enthält alle bisherigen Makros) + +Referenz: MACRO, S. #to page ("MACRO")# + + + +#goal page ("MIN")##ib (2)#MIN#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Minimum zweier Größen + +Format: MIN(<Zahl1>,<Zahl2>) + +Erklärung: Liefert die kleinere Zahl aus <Zahl1> und <Zahl2> + +Beispiel: N X=MIN(1.0,2.0) (X = 1.0) + + +Programm: "dyn.forst7" + +Referenz: MAX, S. #to page ("MAX")# + + + +#goal page ("N")##ib (2)#N#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Initialisierungsgleichung + +Format: N <Name>=<Zahl> + +Erklärung: Initialisert eine Variable mit dem Bezeichner <Name> auf den Wert + <Zahl>, d.h. es wird ihr ein Startwert zugewiesen. + +Beispiel: N X=1900 + +Programm: "dyn.grashasenfuchs" + + + +#goal page ("NOISE")##ib (2)#NOISE#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Pseudo-Zufallszahlen-Generator + +Format: NOISE(<Zahl>) + +Erklärung: Diese Funktion liefert eine Pseudo-Zufallszahl zwischen -0.5 und +0.5 + und setzt einen neuen Startwert für den Generator fest. Der Parameter + <Zahl> wird nicht ausgewertet. + +Beispiel: N X=NOISE(0) + +Referenz: NORMRN, S. #to page ("NORMRN")# + + + +#goal page ("NORMRN")##ib (2)#NORMRN#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Pseudo-Zufallszahlen-Generator + +Format: NORM(<Zahl1>,<Zahl2>) + +Erklärung: Liefert einen Wert zwischen <Zahl1> - <Zahl2> * 2.4 und <Zahl1> + + <Zahl2> * 2.4. + +Beispiel: N X=NORM(1.0,10.0) + +Referenz: NOISE, S. #to page ("NOISE")# + + + +#ib (2)#NOTE#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Kommentar + +Format: NOTE <Kommentarzeile> + +Erklärung: Die Zeilen, die mit NOTE gekennzeichnet sind, werden vom Compiler als + Kommentarzeilen erkannt und nicht beachtet. NOTE-Zeilen haben nur + dokumentierenden Charakter und sind für den Programmlauf ohne jede + Bedeutung. Dennoch sollte man, wenn immer möglich, Kommentare in + sein DYNAMO-Programm einfügen, denn sie sind in DYNAMO an + nähernd die einzige Möglichkeit, ein Programm lesbar zu machen, damit + es auch nach längerer Zeit noch korrigiert werden kann. + +Beispiel: NOTE Dies ist eine Kommentarzeile + +Programm: "dyn.welt/forrester" + + + +#goal page ("PLOT")##ib (2)#PLOT#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Darstellen der Ergebnisse in Diagrammform + +Format: PLOT <Name>[=<Druckzeichen>][(<Skalenbegin>, + <Skalenende>)][/...][,...] + +Erklärung: Durch diese Anweisung werden die Größen nach PLTPER Zeiteinheiten + in einem Diagramm ausgegeben. Die Angabe eines Druckzeichens ist + nur bei zeichenorientierten Grafik erforderlich, denn bei hochauflösender + Grafik werden die Graphen der verschiedenen Größen durch unterschied + liche Linientypen gezeichnet; fehlt bei der zeichenorientierten Grafik das + Druckzeichen, so werden die Graphen durch die Zahlen von 0...9 darge + stellt. Bei "/" werden verschiedene, bei "," gleiche Skalen benutzt. + +Beispiel: PLOT GRAS=G(995,1005)/HASEN=H(85,115) + X /FUECHS=F(15,35) + +Programm: "dyn.grashasenfuchs" + +Referenz: PRINT, S. #to page ("PRINT")# + + + +#goal page ("POWER")##ib (2)#POWER#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Potenzfunktion + +Format: POWER(<Zahl1>,<Zahl2>) + +Erklärung: Liefert <Zahl1>#u#<Zahl2>#e# + +Beipiel: N X=POWER(2, 2) (X = 4) + + +Referenz: SQRT, S. #to page ("SQRT")# + + + +#goal page ("PRINT")##ib (2)#PRINT#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Darstellung der Ergebnisse in Tabellenform + +Format: PRINT <Name>[/...][,...] + +Erklärung: Durch diese Anweisung werden die Werte (<Name>) nach PRTPER + Zeiteinheiten in einer Tabelle ausgegeben. Die Ausgabe kann umgeleitet + werden (s. 'protokoll'). + +Beispiel: PRINT GBEV,BEV(1),BEV(40),BEV(60),BEV(63) + X ,BEV(65),ZBEV,PRENT + +Programm: "dyn.bev" + +Referenz: PLOT, S. #to page ("PLOT")# + + + +#goal page ("R")##ib (2)#R#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Rate-Gleichung + +Format: R<Rate-Name>.KL=<Gegenwartsausdruck> + +Erklärung: Eine Rate-Gleichung stellt die Veränderungsrate in Bezug zu den aktu + ellen Level-Größen. + +Beispiel: R FGRATE.KL=FGK*HASEN*FUECHS.K + + +Programm: "dyn.grashasenfuchs" + +Referenz: A, S. #to page ("A")# + C, S. #to page ("C")# + L, S. #to page ("L")# + + + +#ib (2)#RAMP#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Wert nach Bedingung + +Format: RAMP(<Zahl1>,<Zahl2>) + +Erklärung: Wenn TIME kleiner <Zahl2>, dann liefert RAMP 0, andernfalls wird + <Zahl1> * (TIME - <Zahl2>) geliefert. + + + IF TIME < <Zahl2> THEN + 0 + ELSE + <Zahl1> * (TIME - <Zahl2>) + END IF + + + +#goal page ("RUN")##ib (2)#RUN#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Überschrift + +Format: RUN <Überschrift> + +Erklärung: Gibt dem aktuellen Lauf eine Überschrift. Gleichzeitig ist + "<Überschrift>.const" der Name eines Datenraums, in dem die Kon + stanten dieses Laufs aufgehoben werden (s. 'run' im Runtime-System). + +Beispiel: RUN Überschrift + +Referenz: *, S. #to page ("*")# + + + +#ib (2)#S#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Supplementary-Gleichung + +Format: S <Name>.K=<Vergangenheitsausdruck> + +Erklärung: Gleichungen für Hilfsgrößen werden durch Supplementary-Gleichungen + ausgedrückt. + +Beispiel: S SCHADSTOFFVERHÄLTNIS.K=COZWEI.K/OZWEI.K + + + + +#ib (2)#SCLPRD#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Skalarprodukt + +Format: SCLPRD(<Tabelle1>,<Zahl1>,<Zahl2>,<Tabelle2>,<Zahl3>) + +Erklärung: Liefert das Skalarprokukt der Tabellen <Tabelle1> und <Tabelle2>, + wobei <Zahl1> und <Zahl2> den Ausschnitt aus der ersten Tabelle + angeben und <Zahl3> den Startindex für den Vektor in der zweiten + Tabelle angibt. + +Beispiel: GB.K=SCLPRD(BEV.K,15,44,GR,1)/2 + + +Programm: "dyn.bev" + + + +#goal page ("SIN")##ib (2)#SIN#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Berechnung der trigonometrischen Funktion Sinus + +Format: SIN(<Zahl>) + +Erklärung: Berechnet den Sinus von <Zahl>, welche im Bogenmaß angegeben + wird. + +Beispiel: N X=SIN(0.5) + +Referenz: COS, S. #to page ("COS")# + COSD, S. #to page ("COSD")# + SIND, S. #to page ("SIND")# + TAN, S. #to page ("TAN")# + TAND, S. #to page ("TAND")# + ARCTAN, S. #to page ("ARCTAN")# + ARCTAND, S. #to page ("ARCTAND")# + + + +#goal page ("SIND")##ib (2)#SIND#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Berechnung der trigonometrischen Funktion Sinus + +Format: SIND(<Zahl>) + +Erklärung: Berechnet den Sinus von <Zahl>, welche im Gradmaß angegeben wird. + +Beispiel: N X=SIND(45.0) + +Referenz: COS, S. #to page ("COS")# + SIN, S. #to page ("SIN")# + COSD, S. #to page ("COSD")# + TAN, S. #to page ("TAN")# + TAND, S. #to page ("TAND")# + ARCTAN, S. #to page ("ARCTAN")# + ARCTAND, S. #to page ("ARCTAND")# + + + +#ib (2)#SPEC#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Lauf-Anweisung + + DT=<Zahl1> +Format: SPEC { LENGTH=<Zahl2> }[/...] + PLTPER=<Zahl3> + PRTPER=<Zahl4> + +Erklärung: Durch die Lauf-Anweisung werden die Systemkonstanten festgesetzt. + Sie darf pro Lauf nur einmal benutzt werden. + +Beispiel: SPEC DT=1/PLTPER=1/PRTPER=1/LENGTH=2000 + + +Referenz: C, S. #to page ("C")# (SPEC kann durch C-Def. ersetzt werden) + + + +#goal page ("SQRT")##ib (2)#SQRT#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Quadratwurzel + +Format: SQRT(<Zahl>) + +Erklärung: Berechnet die Quadratwurzel aus <Zahl> + +Beispiel: N X=SQRT(4.0) (X = 2.0) + + +Referenz: POWER, S. #to page ("POWER")# + + + +#ib (2)#STEP#ie (2)##on ("i")##right#Funktion#off ("i")# + +Zweck: Wert nach Bedingung + +Format: STEP(<Zahl1>,<Zahl2>) + +Erklärung: Ist TIME kleiner <Zahl2>, so wird 0 geliefert, ansonsten <Zahl1> + + + IF TIME < <Zahl2> THEN + 0.0 + ELSE + <Zahl1> + END IF + +Beispiel: N X=STEP(12.0,12.0) + + + +#goal page ("SUM")##ib (2)#SUM#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Summierung einer Tabelle + +Format: SUM(<Tabelle>) + +Erklärung: Liefert die Summe der Einträge in einer Tabelle + +Beispiel: A GESAMTBEV.K=SUM(BEV.K) + +Programm: "dyn.bev" + +Referenz: SUMV, S. #to page ("SUMV")# + + + +#goal page ("SUMV")##ib (2)#SUMV#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Summierung einer Tabelle + +Format: SUMV(<Tabelle>,<Zahl1>,<Zahl2>) + +Erklärung: Summierung der Einträge in der Tabelle von Element <Zahl1> bis + Element <Zahl2> + +Beispiel: A ZBEV.K=SUMV(BEV.K,16,59) Teilbevölkerung + + +Programm: "dyn.bev" + +Referenz: SUM, S. #to page ("SUM")# + + + +#goal page ("SWITCH")##ib (2)#SWITCH#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Wert nach Bedingung + +Format: SWITCH(<Zahl1>,<Zahl2>,<Zahl3>) + +Erklärung: Wenn der Parameter <Zahl3> den Wert 0 hat, so wird <Zahl1> + geliefert, andernfalls <Zahl2> (gleichbedeutend mit FIFZE). + + + IF <Zahl3> = 0 THEN + <Zahl1> + ELSE + <Zahl2> + END IF + +Beispiel: N X=SWITCH(1.0,2.0,3.0) (X = 2.0) + + +Referenz: FIFZE, S. #to page ("FIFZE")# + + + +#goal page ("T")##ib (2)#T#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Tabellen-Definition + +Format: T <Name>=<Zahl1>[/<Zahl2>[....]] + +Erklärung: Durch die T-Anweisung wird eine Tabelle definiert, die Elemente wer + den durch "/" getrennt hintereinander angegeben. + +Beispiel: T TABELLE=1/2/3/4/5/6/8/9/10/11/12 + + +Programm: "dyn.bev" + +Referenz: TABLE, S. #to page ("TABLE")# + TABHL, S. #to page ("TABHL")# + + + +#goal page ("TABHL")##ib (2)#TABHL#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Tabellenfunktion + +Format: TABHL(<Tabelle>,<Zahl1>,<Zahl2>,<Zahl3>) + +Erklärung: IF <Zahl1> < <Zahl2> THEN + <Tabelle> (<Zahl2>) + ELIF <Zahl2> <= <Zahl1> AND <Zahl1> <= <Zahl3> THEN + TABLE (<Tabelle>, <Zahl1>, <Zahl2>, <Zahl3>) + ELSE + <Tabelle> (<Zahl3>) + END IF + +Beispiel: A BRMM.K=TABHL(BRMMT,MSL.K,0,5,1) + + +Programm: "dyn.welt/forrester" + +Referenz: T, S. #to page ("T")# + TABLE, S. #to page ("TABLE")# + + + +#goal page ("TABLE")##ib (2)#TABLE#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Tabellenfunktion + +Format: TABLE(<Tabelle>,<Zahl1>,<Zahl2>,<Zahl3>,<Zahl4>) + +Erklärung: Verknüpft die Werte aus <Tabelle> mit <Zahl1>, wobei <Zahl2> den + ersten und <Zahl3> den letzten Tabelleneintrag angibt. <Zahl4> stellt + die Schrittweite dar. + +Beispiel: T TABELLE=1/2/3/4/5 + A BEISP.K=TABLE(TABELLE,X.K,2,4,1) + +Programm: "dyn.welt/forrester" + +Referenz: T, S. #to page ("T")# + TABHL, S. #to page ("TABHL")# + + + +#goal page ("TAN")##ib (2)#TAN#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Berechnung der trigonometrischen Funktion Tangens + +Format: TAN(<Zahl>) + +Erklärung: Berechnet den Tangens von <Zahl>, welche im Bogenmaß angegeben + wird. + +Beispiel: N X=TAN(0.5) + +Referenz: COS, S. #to page ("COS")# + SIN, S. #to page ("SIN")# + COSD, S. #to page ("COSD")# + SIND, S. #to page ("TAN")# + TAND, S. #to page ("TAND")# + ARCTAN, S. #to page ("ARCTAN")# + ARCTAND, S. #to page ("ARCTAND")# + + + +#goal page ("TAND")##ib (2)#TAND#ie (2)##on ("i")##right#Funktion#off ("i")# + + +Zweck: Berechnung der trigonometrischen Funktion Tangens + +Format: TAND(<Zahl>) + +Erklärung: Berechnet den Tangens von <Zahl>, welche im Gradmaß angegeben + wird. + +Beispiel: N X=TAND(45.0) + +Referenz: COS, S. #to page ("COS")# + SIN, S. #to page ("SIN")# + COSD, S. #to page ("COSD")# + TAN, S. #to page ("TAN")# + SIND, S. #to page ("SIND")# + ARCTAN, S. #to page ("ARCTAN")# + ARCTAND, S. #to page ("ARCTAND")# + + + +#goalpage ("X")##ib (2)#X#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Fortsetzungszeile + +Format: X <Fortsetzungszeile> + +Erklärung: Eine in der vorangegangenen Zeile nicht beendete Anweisung wird nach + einer X-Anweisung fortgesetzt (Es können beliebig viele X-Anweisun + gen nacheinander folgen). + +Beispiel: T TABELLE=1/2/3/4/5/6/7/8/9/10/11/12/13/14 + X /15/16/17/18/19 + +Programm: "dyn.bev" + + + +#goal page ("*")##ib (2)#*#ie (2)##on ("i")##right#Anweisung#off ("i")# + + +Zweck: Überschrift + +Format: * <Überschrift> + +Erklärung: Gibt dem aktuellen Lauf eine Überschrift + +Beispiel: * Überschrift + +Referenz: RUN, S. #to page ("RUN")# +#page# + +#ib#5. Makros in DYNAMO#ie# + + + + +Der DYNAMO-Compiler bietet die Möglichkeit, benutzereigene Funktionen zu definie +ren. Makros werden ähnlich wie Refinements in ELAN in das DYNAMO-Programm +eingesetzt. Beim EUMEL-DYNAMO-Compiler werden mit "zz" beginnende Namen +generiert, so daß Sie es vermeiden sollten, eigene Namen mit "zz" beginnen zu +lassen. Weiterhin sollte man als Namen der aktuellen Parameter nicht die Namen der +formellen Parameter verwenden. + +Folgende Makros werden standardmäßig vom DYNAMO-Compiler zur Verfügung +gestellt: + + macro delay1 (in, del) Verzögerung erster Ordnung + + macro delay3 (in, del) Verzögerung dritter Ordnung + Material + + macro delay3p (in, del, ppl) Verzögerung dritter Ordnung mit + Pipeline + + macro delinf3 (in, del) Verzögerung dritter Ordnung für + Information + + macro smooth (in, del) Verzögerung erster Ordnung für + Information + + + + +#ib#5.1. Insertieren von Makros#ie# + + + + +Makros werden durch folgende Prozedur in die Compilertabelle eingetragen: + + +PROC insert macro (TEXT CONST filename): + + Zweck: Fügt die in der Datei 'filename' enthaltenen Makros in die Makrotabelle ein. + Die Datei sollte zweckmäßigerweise nur Makrodefinitionen enthalten. Es ist + - im Gegensatz zu normalen DYNAMO-Programmen - nicht nötig, die + Systemkonstanten zu definieren (die Standard-Makros sind in der Datei + "dyn.mac" enthalten; diese Datei kann beliebig ergänzt werden). + + + + +#ib#5.2. Aufbau eines Makros#ie# + + + + +Makros beginnen in DYNAMO immer mit der Anweisung MACRO (s. auch Seite #to page ("MACRO")#) +und enden mit MEND (s. Seite #to page ("MEND")#). Dazwischen steht ein Makrorumpf, bestehend +aus einer oder mehreren DYNAMO-Gleichungen. Beim Makroaufruf können, soweit +vorher definiert, Parameter angegeben werden, jedoch rekursiv aufrufen kann man +Makros nicht. + +Beispiel: MACRO SMOOTH (IN, DEL) + L SMOOTH.K = SMOOTH.J + DT * (IN.J - SMOOTH.J) + X /DEL + N SMOOTH = IN + MEND + +Lokale Variablen in Makros beginnen mit einem $-Zeichen. Der Makro-Expandierer +ersetzt das $-Zeichen durch "zz" gefolgt von einer Zahl. Aus diesem Grund sollen +eigene Namen nicht mit "zz" beginnen. + +Falls Sie eine Fehlermeldung bekommen, die sich auf einen mit "zz" beginnenden +Namen bezieht, sollten Sie den Fehler in dem entsprechenden Makro suchen. + +#on ("b")# +Achtung: #off ("b")#Makros sollten nur von fortgeschrittenden DYNAMO-Programmieren + verwendet werden, da Makros Eigenschaften von Refinements (textuelle + Ersetzung) und Prozeduren (Parameterübergabe) vereinigen. Der daraus + folgende Effekt ist nicht ganz einfach zu durchschauen. +#page# + + + +#ib#6. Erweiterung des Sprachumfangs#ie# + + + + +Während Makros in DYNAMO geschrieben werden, ist es ferner möglich, die Menge +der Funktionen mittels der Sprache ELAN zu erweitern. + +Hierbei geht man wie folgt vor: + + 1. Schreiben einer Funktion in ELAN (näheres siehe unten) + + 2. Einbinden der Funktion in die Tabellen des DYNAMO-Compilers + + 2.1. Einschreiben des Namens der Funktion, gefolgt von den Typen der Ein + gabeparameter in die bestehende Datei "dyn.std", wobei folgende Typen + existieren: + + r real (Datentyp REAL) + t table (Datentyp TAB) + + Abgeschlossen wird die "dyn.std"-Datei durch die Zeichensequenz "/*". + + Beispiele: + + power rr table trrrr /* + + + 2.2. Laden der Funktion(en) mittels der Prozedur 'init std ("dyn.std")' + + +Eine zur Einbindung in den DYNAMO-Compiler vorgesehene ELAN-Funktion wird +unter Beachtung gewisser Regeln erstellt: + + 1. Die deklarierten ELAN-Prozeduren dürfen nur Parameter vom Typ REAL oder + TAB besitzen oder gänzlich ohne Parameter sein. + + 2. Der Typ des Resultaten muß vom Typ REAL sein. + +Zur Manipulation von Tabellen wurde der Datentyp TAB geschaffen, auf welchen man +wie auf das Standard-Vektorpaket zugreifen kann. + +Beispiel: + + REAL PROC abs (REAL CONST a): + IF a < 0.0 THEN + -a + ELSE + a + END IF + END PROC abs; + + PROC sumv (TAB CONST tab, REAL CONST erstes, letztes): + REAL VAR summe := 0.0; + INT VAR i; + FOR i FROM int (erstes) UPTO int (letztes) REPEAT + summe INCR wert (tab, i) + END REPEAT; + summe + END PROC sumv + + + + +#ib#6.1. Für fortgeschrittende ELAN-Program + mierer#ie# + + + +Der Quellcode des EUMEL-DYNAMO-Compilers wird mit ausgeliefert. Daher +können Einschränkungen (s. 3.2 Abweichungen gegenüber dem Sprachstandard) +leicht beseitigt werden. Wem z.B. die Anzahl der Gleichungen (950) zu wenig ist, der +kann im Quelltext des Compilers diesen Wert (annähernd) beliebig nach oben hin +erhöhen. + diff --git a/lang/dynamo/1.8.7/doc/dynamo handbuch.index b/lang/dynamo/1.8.7/doc/dynamo handbuch.index new file mode 100644 index 0000000..af77d79 --- /dev/null +++ b/lang/dynamo/1.8.7/doc/dynamo handbuch.index @@ -0,0 +1,69 @@ +#block##pageblock##page (52)# +#head# +#center#DYNAMO-Compiler +#center#____________________________________________________________ + +#end# +#bottom odd# +#center#____________________________________________________________ +GMD #right#DYNAMO - % +#end# +#bottom even# +#center#____________________________________________________________ +DYNAMO - % #right#GMD +#end# +Anhang - Übersicht über Anweisungen und +Funktionen + + +#clear pos##l pos (0.0)##r pos (10.0)##fillchar (" ")# +#table# +A 21 +ABS 21 +ARCTAND 22 +C 23 +CLIP 23 +COSD 24 +EXP 25 +FIFGE 25 +FIFZE 26 +FLOOR 26 +FOR 27 +FRAC 27 +L 28 +LN 28 +LOG2 29 +LOG10 29 +MACRO 30 +MAX 31 +MEND 31 +MIN 32 +N 32 +NOISE 33 +NORMRN 33 +NOTE 34 +PLOT 35 +POWER 35 +PRINT 36 +R 36 +RAMP 37 +RUN 37 +S 38 +SCLPRD 38 +SIN 39 +SIND 39 +SPEC 40 +SQRT 40 +STEP 41 +SUM 41 +SUMV 42 +SWITCH 42 +T 43 +TABHL 43 +TABLE 44 +TAN 44 +TAND 45 +X 45 +* 46 +#table end# + diff --git a/lang/dynamo/1.8.7/doc/dynamo handbuch.inhalt b/lang/dynamo/1.8.7/doc/dynamo handbuch.inhalt new file mode 100644 index 0000000..2d1b1f3 --- /dev/null +++ b/lang/dynamo/1.8.7/doc/dynamo handbuch.inhalt @@ -0,0 +1,131 @@ +____________________________________________________________________________ + + +#on("b")##on ("u")# +#center#Betriebssystem E U M E L +#off ("u")# + + +#center#DYNAMO + + + + +#off("b")# +#center#Lizenzfreie Software der +#on ("b")# + +#center#Gesellschaft für Mathematik und Datenverarbeitung mbH, +#center#5205 Sankt Augustin + + +#off("b")# +#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für +#center#nichtkommerzielle Zwecke gestattet. + +#center#Gewährleistung und Haftung werden ausgeschlossen + + +____________________________________________________________________________ +#page# +#block# +#center#____________________________________________________________________________ + + Copyright 1988 + + Selbstverlag GMD + Alle Rechte vorbehalten. + Insbesondere ist die Überführung in maschinenlesbare + Form, sowie das Speichern in Informationssystemen, auch + auszugsweise, nur mit schriftlicher Genehmigung der + GMD gestattet. +#center#____________________________________________________________________________ + + + Herausgeber: + + Gesellschaft für Mathematik und Datenverarbeitung mbH + + Postfach 1240, Schloß Birlinghoven + D-5205 Sankt Augustin 1 + Telefon(02241) 14-1, Telex 8 89 469 gmd d + Telefax(02241) 14 28 89, BTX *43900\# + Teletex 2627-224135=GMDVV + + +Autor: + + Christian Szymanski + +nach Anregungen von: + + Diether Craemer, Robert Keil + +überarbeitet von: + + Thomas Müller + +Texterstellung: + + Dieser Text wurde mit der EUMEL-Textverarbeitung erstellt und aufbereitet und + mit dem Agfa Laserdrucksystem P400 gedruckt. + + + + Hinweis: + +#on("italics")# + Diese Dokumentation wurde mit größtmöglicher Sorgfalt erstellt. Dennoch wird + für die Korrektheit und Vollständigkeit der gemachten Angaben keine Gewähr + übernommen. Bei vermuteten Fehlern der Software oder der Dokumentation + bitten wir um baldige Meldung, damit eine Korrektur möglichst rasch erfolgen + kann. Anregungen und Kritik sind jederzeit willkommen.#off("italics")# +#page# +#pagenr ("%", 1")##setcount (1)##block##pageblock##count per page# +#head# +#center#DYNAMO-Compiler +#center#____________________________________________________________ + +#end# +#bottom odd# +#center#____________________________________________________________ +GMD #right#DYNAMO - % +#end# +#bottom even# +#center#____________________________________________________________ +DYNAMO - % #right#GMD +#end# + +Inhalt + + + +#clear pos##lpos (0.0)##r pos (10.0)##fillchar (" ")# +#table# +1. Einleitung 2 + 1.1. Referenzliteratur 2 + 1.2. Die Programmiersprache DYNAMO 3 + 1.3. Kurz-Einführung in die DYNAMO-Schreibweise 4 + 1.4. Eine erste, kleine Sitzung mit dem DYNAMO-System 6 + +2. Generierung des DYNAMO-Compilers 7 + +3. Der EUMEL-DYNAMO-Compiler 8 + 3.1. Benutzung des DYNAMO-Compiler 8 + 3.2. Abweichungen gegenüber dem Sprachstandard 11 + 3.3. Das DYNAMO Runtime-System 12 + 3.4. Fehlermeldungen des DYNAMO-Compilers 14 + +4. Anweisungen und Funktionen des EUMEL-DYNAMO-Compilers 19 + 4.1. Übersicht über die Anweisungen und Funktionen 21 + +5. Makros in DYNAMO 47 + 5.1. Insertieren von Makros 48 + 5.2. Aufbau eines Makros 48 + +6. Erweiterung des Sprachumfangs 50 + 6.1. Für fortgeschrittende ELAN-Programmierer 51 + +Anhang - Übersicht über Anweisungen unf Funktionen 52 +#table end# + diff --git a/lang/dynamo/1.8.7/source-disk b/lang/dynamo/1.8.7/source-disk new file mode 100644 index 0000000..e61107d --- /dev/null +++ b/lang/dynamo/1.8.7/source-disk @@ -0,0 +1 @@ +informatikpaket/01_sprachen.img diff --git a/lang/dynamo/1.8.7/src/"15"TAB1"14" b/lang/dynamo/1.8.7/src/"15"TAB1"14" Binary files differnew file mode 100644 index 0000000..ce88e03 --- /dev/null +++ b/lang/dynamo/1.8.7/src/"15"TAB1"14" diff --git a/lang/dynamo/1.8.7/src/dyn.33 b/lang/dynamo/1.8.7/src/dyn.33 new file mode 100644 index 0000000..a17bd55 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.33 @@ -0,0 +1,2073 @@ +(**************************************************************************) +(**************************************************************************) +(****** ******) +(****** ******) +(****** DYNAMO - III - ELAN PRECOMPILER ******) +(****** ******) +(****** ******) +(****** AUTOREN : R. Keil, ******) +(****** T. Froehlich ******) +(****** ******) +(****** VERSION : 3.3.7 ******) +(****** ******) +(****** ******) +(****** AENDERUNGEN: ******) +(****** 05.10.1983 ******) +(****** 06.05.1985 Hua&DC: forget("zzdyn.const") ******) +(****** 08.04.1986 Ley : Anpassung an 1.7.5 ******) +(****** 02.04.1987 C.Fallis & C.Rensen Einbettung in BOX ******) +(****** 18.05.1988 dc: Udi Katzirs changes ******) +(****** should declare vector eingeführt ******) +(****** 20.05.1988 dc: already used in loop body eingeführt ******) +(****** Fehlermeldung bei Ref. int index unterdrückt ******) +(****** weil sie wahrscheinlich selbst ein Fehler ist ******) +(****** 21.07.1988 Christian Szymanski ******) +(****** Ausbettung aus BOX ******) +(****** ******) +(****** ******) +(**************************************************************************) +(**************************************************************************) + + +PACKET dynamo compiler 33 DEFINES init std, dynamo, insert macro, + erase, table dump, graphic: + +(********************** T A B L E S ********************************) + +LET max tab size = 950, + max hash size = 300, + library = ""15"TAB1"14"", + tab name = ""15"TAB2"14""; + +BOOL VAR is draw := FALSE; + +TYPE TABLE = STRUCT (ROW max tab size TEXT name, init, right part, + ROW max tab size INT type, line no, pred, mac, + index, index type, + ROW max tab size BOOL in use, idef, rdef, + already used in loop body, + should declare vector, + (*18.5.88 dc: Änderung von Udi Katzir *) + ROW max hash size INT class, + INT tab size, + tab beg); + +(* already used in loop body: is set to TRUE , if that table-element has been + used to generate a line within a loop --> PROC gen loop 20.5.88 dc*) + +(* should declare vector : used when rows are declared and indicates if the*) +(* length of the row is to be taken from the index of the current variable *) + +BOUND TABLE VAR tab; + +PROC enter (TEXT CONST name, right part, INT CONST type of equ) : + INT VAR tab pos; + INT CONST hash class := hash (name); + search (name, tab pos, lmp, equtype, hash class); + table index := tab pos; + enter equ. + + enter equ : + IF not found OR subscript COR CONCR (tab).type (tabpos) = mac param + THEN enter name + ELIF type of equ = nequ + THEN enter nequ + ELIF CONCR (tab).right part (tab pos) = nt + THEN complete nequ + ELSE err (name, 1) + FI. + + equtype : + IF subscript + THEN type of equ + ELSE nil + FI. + + enter name : + CONCR (tab).tab size INCR 1; + tab size := CONCR (tab).tab size; + IF tab size > max tab size + THEN errorstop ("dynamo table overflow") + FI; + IF type of equ = nequ + THEN CONCR (tab).init (tab size) := right part; + CONCR (tab).right part (tab size) := nt + ELSE CONCR (tab).init (tab size) := nt; + CONCR (tab).right part (tab size) := right part + FI; + init element. + + init element : + CONCR (tab).name (tab size) := name; + CONCR (tab).type (tab size) := type of equ; + CONCR (tab).line no (tab size) := line no; + CONCR (tab).mac (tab size) := lmp; + CONCR (tab).index (tab size) := nil; + CONCR (tab).index type (tab size) := nil; + CONCR (tab).in use (tab size) := FALSE; + CONCR (tab).idef (tab size) := FALSE; + CONCR (tab).rdef (tab size) := FALSE; + CONCR (tab).already used in loop body (tab size) := FALSE; + CONCR (tab).pred (tab size) := CONCR (tab).class (hash class); + CONCR (tab).class (hash class) := tab size. + + enter nequ : + IF CONCR (tab).init (tab pos) <> nt + THEN err (name, 2) + FI; + CONCR (tab).init (tab pos) := right part. + + complete nequ : + CONCR (tab).right part (tab pos) := right part; + CONCR (tab).type (tab pos) := type of equ; + CONCR (tab).line no (tab pos) := line no. +END PROC enter; + +PROC test (TEXT CONST name, INT VAR tab pos, INT CONST last mp, type, + err no) : + search (name, tab pos, last mp, type); + IF not found + THEN err (err no) + FI +END PROC test; + +PROC search (TEXT CONST name, INT VAR tab pos, INT CONST last mp, type) : + search (name, tab pos, last mp, type, hash (name)) +END PROC search; + +PROC search (TEXT CONST name, INT VAR tab pos, + INT CONST last mp, type, hash class) : + not found := TRUE; + tab pos := CONCR (tab).class (hash class); + WHILE tab pos <> nil CAND name not found REP + tab pos := CONCR (tab).pred (tab pos) + PER. + + name not found : + not found := NOT (CONCR (tab).name (tab pos) = name + AND same macro AND type ok); + not found. + + same macro : + CONCR (tab).mac (tab pos) = last mp. + + type ok : + type = nil OR CONCR (tab).type (tab pos) = type. +END PROC search; + +PROC insert macro (TEXT CONST source) : + dynamo (source, ""8"", FALSE); + kill (""8""); + IF errors = nil + THEN kill (library); + copy (tab name, library) + FI +END PROC insert macro; + +PROC init std (TEXT CONST std name) : + lmp := nil; + kill (library); + tab := new (library); + FOR i FROM 1 UPTO max hash size REP + CONCR (tab).class (i) := nil + END REP; + CONCR (tab).tab size := nil; + enter std procs; + CONCR (tab).tab beg := tab size + 1. + +enter std procs : + FILE VAR std file := sequential file (input, std name); + TEXT VAR name, params; + WHILE NOT eof (std file) REP + get (std file, name); + test eof; + IF params = "()" + THEN params := "" + FI; + enter (name, params, std p) + END REP. + + test eof : + IF name = "/*" + THEN LEAVE enter std procs + ELSE get (std file, params) + FI. +END PROC init std; + +PROC next sym : + next sym (scan buf, sym, type, scan position) +END PROC next sym; + +PROC next sym (TEXT CONST buf) : + next sym (buf, sym, type, scan position) +END PROC next sym; + +PROC test open bracket (TEXT CONST sym) : + IF sym <> "(" + THEN err (sym, 6) + FI +END PROC test open bracket; + +PROC test closing bracket (TEXT CONST sym) : + IF sym <> ")" + THEN err (sym, 58) + FI +END PROC test closing bracket; + +PROC test bold (INT CONST err no) : + IF type <> bold + THEN err (err no) + FI +END PROC test bold; + +PROC test equal (INT CONST err no) : + IF sym <> "=" + THEN err (err no) + FI +END PROC test equal; + +BOOL OP IN (TEXT CONST pattern, source) : + pos (source, pattern) > nil. +END OP IN; + +PROC scan (TEXT CONST buf) : + scan buf := buf; + scan position := 1 +END PROC scan; + +PROC err (TEXT CONST a, INT CONST b) : + err (a, b, line no) +END PROC err; + +PROC err (INT CONST i) : + err (sym, i, line no) +END PROC err; + +PROC gen (TEXT CONST a) : + out buf CAT a +END PROC gen; + +PROC gen (TEXT CONST a, b) : + out buf CAT a; + out buf CAT b +END PROC gen; + +PROC gen (TEXT CONST a, b, c) : + out buf CAT a; + out buf CAT b; + out buf CAT c +END PROC gen; + +PROC gen (TEXT CONST a, b, c, d) : + out buf CAT a; + out buf CAT b; + out buf CAT c; + out buf CAT d +END PROC gen; + +PROC genln (TEXT CONST a, b, c) : + gen (a, b, c); + lf +END PROC genln; + +PROC lf : + putline (target, outbuf); + outbuf := nt +END PROC lf; + +PROC gen ln (TEXT CONST t) : + outbuf CAT t; + putline (target, outbuf); + outbuf := nt +END PROC gen ln; + +PROC erase (BOOL CONST b) : + erase option := b +END PROC erase; + +PROC dynamo (TEXT CONST s) : + TEXT VAR target name := s + ".elan"; + dynamo (s, target name, TRUE); + IF erase option + THEN kill (target name) + FI; + last param (s) +END PROC dynamo; + +PROC dynamo : + dynamo (last param) +END PROC dynamo; + +PROC graphic (BOOL CONST mode): + is draw := NOT mode +END PROC graphic; + +(********************** C O M P I L E R ************************) + +LET bold = 1, number = 2, + delimiter = 3, eol = 4, + aux = 1, rate = 2, + level = 3, nequ = 4, + mac name = 6, std p = 7, + sub init = 8, table = 9, + for = 10, mac param = 11, + const = 12, print = 1, + plot = 2, global param = 1, + none = 3, max print no = 10, + supp = 5, any = "ß"; + +FILE VAR source, target; + +ROW max print no TEXT VAR print param; + +ROW 10 TEXT VAR plot name, id; +ROW 10 INT VAR scale pointer; +ROW 10 TEXT VAR lower bound, upper bound; +ROW 10 BOOL VAR l fixed scale, u fixed scale; + +TEXT VAR buffer, left part, right part, outbuf, print buf, + headline, sym, plot buf, asterisk buffer, + macro name, noise buffer, constant, run buffer, + scan buf; + +INT VAR print param no, print line no, tab beg, type, line no, + plot line no, scale counter, plot param no, + last pos, lmp, index, (* lmp = Last Macro Position *) + index type, for index, i, tab size, expansion no, + table index, scan position, old tab beg; + +BOOL VAR k, kl, is first, fixed scale, in macro, + in loop, not found, internal, subscript, + erase option := FALSE; + +TEXT CONST nt := ""; + +INT CONST nil := 0; + + +(*$$$$$$$$$$ ZUSATZ C & C 20.2.87 eingefuegt : error listing $$$$$$$$$*) +(* Diese Prozedur erzeugt einen zweigeteilten Bildschirm, wobei *) +(* die Datei 'procsource' (d.h. das Dynamo-Quellprogramm) in der *) +(* oberen Haelfte und die Fehlerdatei 'notebook' in der unteren *) +(* Haelfte steht. *) + +PROC error listing (FILE VAR procsource) : (* C.S. 21.07.88 *) + note edit (procsource); +END PROC error listing; +(*$$$$$$$$$$$$$$$$$$$$ ENDE ZUSATZ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$*) + + +PROC dynamo (TEXT CONST source name, target name, BOOL CONST pass2) : + init dynamo; + first pass; + IF no errors + THEN second pass + ELSE error listing(source); + error stop ("") (* C.S. 21.07.88 *) + (* Falls Fehler im ersten Durchlauf gefunden wurden, wird der zweite *) + (* Durchlauf erst gar nicht durchgefuehrt, sondern das fehlerhafte *) + (* Dynamo-Programm und die Fehlerdatei werden ausgegeben . *) + FI. + + first pass : + WHILE NOT eof (source) REP + read source line; + translate line + PER; + IF NOT pass2 + THEN LEAVE dynamo + FI; + end of first pass. + + second pass : + generate initializations; + generate equations. + + generate initializations : + generate rts call; + generate noise card; + generate table part; + generate for variables; + generate variable part; + generate table init; + generate init print; + generate init plot; + generate init scale; + generate asterisk; + gen repeat. + + generate equations : + generate print line; + generate plot line; + gen equations (level); + gen equations (aux); + gen equations (supp); + gen equations (rate); + gen end repeat; + IF no errors + THEN run (target name) + ELSE error listing(source); + error stop ("") (* C.S. 21.07.88 *) + (* Falls im zweiten Durchlauf Fehler gefunden wurden, wird das *) + (* ELAN-Zielprogramm nicht ausgefuehrt, sondern das fehlerhafte *) + (* Dynamo-Quellprogramm und die Fehlerdatei werden ausgegeben . *) + FI. + + init dynamo : + kill (target name); + init tables; + source := sequential file (input, source name); + target := sequential file (output, target name); + print buf := nt; + outbuf := nt; + plot buf := nt; + noise buffer := nt; + asterisk buffer := nt; + macro name := nt; + run buffer := "zzdyn"; + line no := nil; + plot param no := nil; + last pos := nil; + lmp := nil; + index := nil; + index type := nil; + expansion no := nil; + in macro := FALSE; + internal := FALSE; + in loop := FALSE; + is first := TRUE; + tab beg := CONCR (tab).tab beg; + old tab beg := CONCR (tab).tab size + 1; + init errors. + + init tables : + kill (tab name); + copy (library, tab name); + tab := old (tab name). + + read source line : + line no INCR 1; + getline (source, buffer); + cout (line no); + scan (buffer); + next sym. + + translate line : + TEXT VAR start := sym; + next sym; + WHILE sym = " " REP next sym PER; + SELECT + pos ("a c l n r print plot note EOL spec * x macro mend for s noise run ", + start + " ") OF + CASE 1 : enter equ (TRUE, FALSE, aux, 9) + CASE 3, 31 : constant equ + CASE 5 : enter equ (TRUE, FALSE, level, 11) + CASE 7 : enter equ (FALSE, FALSE, nequ, 56) + CASE 9 : enter equ (FALSE, TRUE, rate, 12) + CASE 11 : print card + CASE 17 : plot card + CASE 22, 27 : (* comment; empty line *) + CASE 36 : gen headline + CASE 15 : enter equ (FALSE, FALSE, table, 13) + CASE 38 : continuation card + CASE 40 : macro card + CASE 46 : macro end + CASE 51 : for card + CASE 55 : enter equ (TRUE, FALSE, supp, 9) + CASE 57 : noise card + CASE 63 : run card + OTHERWISE : err (start, 3) + END SELECT. + + macro card : + IF in macro + THEN err (4) + FI; + in macro := TRUE; + get macro name; + get macro param list. + + get macro name : + IF type = bold + THEN enter (sym, nt, mac name); + CONCR (tab).line no (tab size) := nil; + macro name := sym; + lmp := tab size + ELSE err (5) + FI. + + get macro param list : + next sym; + test open bracket (sym); + next sym; + WHILE sym <> ")" REP + IF type = bold + THEN enter (sym, nt, mac param) + ELSE err (7) + FI; + next sym; + IF sym = "," + THEN next sym + FI + END REP; + test closing bracket (sym). + + macro end : + lmp := nil; + in macro := FALSE. + + constant equ : + REP + analyze constant equ; + enter (left part, constant, const); + last pos := tab size + UNTIL end of constants PER. + + analyze constant equ : + test bold (10); + left part := sym; + next sym; + test equal (21); + get constant. + + end of constants : + next sym; + test delimiter. + + get constant : + next sym; + IF NOT sym is number (constant) + THEN err (37) + FI. + + print card : + IF print buf = nt + THEN print buf := subtext (buffer, scanposition - length (sym)); + print line no := line no + ELSE print buf CAT "," + subtext (buffer, scanposition - length (sym)) + FI; + last pos := print. + + plot card : + IF plot buf = nt + THEN plot buf := subtext (buffer, scanposition - length (sym)); + plot line no := line no; + ELSE plot buf CAT "/" + subtext (buffer, scanposition - length (sym)) + FI; + last pos := plot. + + gen headline : + asterisk buffer := "asterisk (""" + subtext (buffer, 3) + """);". + + generate asterisk : + IF asterisk buffer <> nt + THEN genln (asterisk buffer) + FI. + + continuation card : + skip blanks; + TEXT CONST tail := subtext (buffer, i); + SELECT last pos OF + CASE print : print buf CAT "," + tail + CASE plot : plot buf CAT "/" + tail + CASE none : err (14) + OTHERWISE : content CAT tail + END SELECT. + + content : + IF CONCR (tab).type (last pos) = nequ + THEN CONCR (tab).init (last pos) + ELSE CONCR (tab).right part (last pos) + FI. + + skip blanks : + i := 1; + REP + i INCR 1 + UNTIL (buffer SUB i) <> " " END REP. + + for card : + REP + read for variable + UNTIL end of forlist END REP. + + end of forlist : + IF sym = "/" + THEN next sym; FALSE + ELSE TRUE + FI. + + read for variable : + TEXT VAR init; (* left part = name *) + test bold (15); (* right part = obere Grenze *) + left part := sym; (* init = untere Grenze *) + next sym; + test equal (16); + next sym; + pass ranges; + enter (left part, right part, for); + CONCR (tab).init (tab size) := init. + + pass ranges : + test number (init); + IF sym <> "," + THEN err (18) + FI; + next sym; + test number (right part). + + noise card : + IF NOT sym is number (noise buffer) + THEN err (66) + FI. + + run card : + test bold (65); + run buffer := sym. + + gen repeat : + lf; + genln ("WHILE time <= length REP");genln (" cout(int(time));"); + genln (" set time (time);"). + + gen end repeat : + genln ("UNTIL " + draw ad + "stop request PER;"); + IF plot buf <> nt + THEN genln (draw ad + "end of program;") + FI; + genln ("END PROC target program"). + + generate rts call : + genln ("forget (""zzdyn.const"",quiet);"); + genln ("run card (""", run buffer, """);"); + genln ("run time system (PROC target program);"); + lf; + genln ("PROC target program :"). + + generate noise card : + IF noise buffer <> nt + THEN genln (" initialize random (", noise buffer, ");") + FI. + + generate plot line : + IF plot buf <> nt + THEN gen plots + FI. + + gen plots : + genln (draw ad + " new plot line (time);"); + FOR i FROM 1 UPTO plot param no REP + genln (draw ad + " plot (", plot name (i), ");"); + genln ("IF " + draw ad + " stop request THEN LEAVE target program " + + "END IF;") + END REP. + + generate print line : + IF print buf <> nt + THEN gen prints + FI. + + gen prints : + genln (" new line (time);"); + FOR i FROM 1 UPTO print param no REP + genln (" print (", printparam (i), ");") + END REP. + + generate init plot : + INT VAR tab pos; + IF plot buf <> nt + THEN search ("pltper", tab pos, nil, const); + IF not found + THEN IF is draw THEN + err ("draw", 25, plot line no) + ELSE + err ("plot", 25, plot line no) + END IF + ELSE genln (draw ad + "initialize plot (""", plot buf, """);"); +(*$$$$$$$$$$$$$ ZUSATZ Februar87 C&C eingefuegt: pltper INCR 0 $$$$$$$$$*) + genln ("pltper INCR 0.0 ;"); + genln (" (* um Warnung des ELAN-Compilers zu unterdruecken *)") +(*$$$$$$$$$$$$$$$$$$$$$$$$$$ ENDE ZUSATZ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$*) + FI + FI. +END PROC dynamo; + +PROC test number (TEXT VAR content) : + SELECT type OF + CASE bold : content := sym + CASE number : content := trunc (sym) + OTHERWISE err (17) + END SELECT; + next sym +END PROC test number; + +PROC enter equ (BOOL CONST x, y, INT CONST exp type, err no) : + get left part; + enter (left part, right part, exp type); + set index; + test global; + IF incorrect time script + THEN err (err no) + FI. + + incorrect time script : + (k XOR x) OR (kl XOR y). + + set index : + INT VAR last entry := table position; + last pos := last entry; + CONCR (tab).index (last entry) := index; + CONCR (tab).index type (last entry) := index type. + + table position : + IF exp type = nequ AND index type = nil AND NOT not found + THEN table index + ELSE tab size + FI. + + test global : + IF in macro AND NOT internal + THEN search global + FI. + + search global : + INT VAR tab pos; + search (left part, tab pos, lmp, mac param); + IF not found + THEN IF left part <> macro name + THEN err (left part, 64) + FI + ELSE CONCR (tab).index (last entry) := tab pos; + CONCR (tab).index type (last entry) := -1; + CONCR (tab).index type (tab pos) := global param; + CONCR (tab).index (tab pos) := last entry + FI. + + get left part : + get name; + get time script; + get index. + + get name : + internal := sym = "$"; + IF internal + THEN next sym; + IF NOT in macro + THEN err (19) + FI + FI; + test bold (20); + left part := sym; next sym. + + get time script : + IF sym = "." + THEN process time script + ELSE k := FALSE; kl := FALSE + FI; + subscript := sym = "(". + + get index : + IF subscript + THEN process index + ELSE index := nil; + index type := nil + FI; + right part := subtext (buffer, scanposition); + test equal (21). + + process time script : + next sym; + k := sym = "k"; kl := sym = "kl"; + next sym. + + process index : + next sym; + SELECT type OF + CASE number : index := int (sym) + CASE bold : search for variable + OTHERWISE : err (22) + END SELECT; + index type := type; + next sym; + test closing bracket (sym); + next sym. + + search for variable : + test (sym, tab pos, lmp, for, 61); + index := tab pos. +END PROC enter equ; + +PROC end of first pass : + INT VAR tab pos; + init time; + search macro calls; + search system constants. + + init time : + search ("time", tab pos, nil, nequ); + IF not found + THEN enter ("time", "0.0", nequ) + FI; + enter ("time", "time.j+dt", level). + + search system constants : + sym := nt; + test ("dt", tab pos, nil, const, 35); + test ("length", tab pos, nil, const, 36). + + search macro calls : + INT VAR old tabsize := tabsize; + FOR i FROM old tabbeg UPTO old tabsize REP + IF is normal equ + THEN enter global macro params + FI + END REP; + tab size := old tabsize. + + is normal equ : + SELECT CONCR (tab).type (i) OF + CASE aux, rate, level, nequ, supp : TRUE + OTHERWISE : FALSE + END SELECT. + + enter global macro params : + enter params (CONCR (tab).right part (i), FALSE); + enter params (CONCR (tab).init (i), TRUE). +END PROC end of first pass; + +PROC enter params (TEXT CONST buf, BOOL CONST is init) : + TEXT VAR macro name; + IF pos (buf, "(") > nil + THEN read params + FI. + + read params : + scan position := 1; + REP + next sym (buf, macro name, type, scan position); + IF type = bold + THEN next sym (buf); + IF sym = "(" + THEN parameter list + FI + FI + UNTIL type = eol END REP. + + parameter list : + INT VAR act param, tab pos; + search (macro name, tab pos, nil, nil); + IF NOT not found CAND CONCR (tab).type (tab pos) = mac name + THEN read param list + FI. + + read param list : + CONCR (tab).index type (tab pos) INCR 1; + act param := tab pos; + REP + next sym (buf); + act param INCR 1; + IF CONCR (tab).type (act param) = mac param + THEN test parameter + ELSE err (macro name, 53) + FI + UNTIL end of parameter list END REP. + + test parameter : + TEXT VAR param; + IF CONCR (tab).index type (act param) = global param + THEN get global param + ELSE get actual param + FI; + content CAT param + "%". + + content : + IF is init + THEN CONCR (tab).init (act param) + ELSE CONCR (tab).right part (act param) + FI. + + get global param : + INT VAR param index; + IF type = bold + THEN enter param + FI. + + enter param : + param index := CONCR (tab).index (act param); + enter (sym, CONCR (tab).right part (param index), + CONCR (tab).type (param index)); + CONCR (tab).init (tab size) := CONCR (tab).init (param index); + CONCR (tab).index (tab size) := act param; + param := sym; + next sym (buf); + get time script. + + get actual param : + INT VAR brackets := nil; + param := nt; + REP + param CAT sym; + next sym (buf); + get time script + UNTIL end of param END REP. + + get time script : + IF sym = "." + THEN param CAT sym; + next sym (buf); + param CAT any; + next sym (buf) + FI. + + end of param : + IF brackets = nil + THEN sym IN ",)" + ELIF sym = "(" + THEN brackets INCR 1; + FALSE + ELIF sym = ")" + THEN brackets DECR 1; + TRUE + ELSE FALSE + FI. + + end of parameter list : + SELECT pos (",)", sym) OF + CASE 1 : FALSE + CASE 2 : TRUE + OTHERWISE : err (50); TRUE + END SELECT. +END PROC enter params; + +(************************* P A S S 2 ***************************) + +PROC generate init print : + INT VAR tab pos; + IF print buf <> nt + THEN test ("prtper", tab pos, nil, const, 24); + gen init + FI. + + gen init : + print param no := nil; + headline := nt; + scan (print buf); + line no := print line no; + cout (line no); + REP + get parameter + UNTIL sym <> "," END REP; + genln ("initialize print (""", headline, """);"); + (*$$$$$$$$$$$$$ ZUSATZ Februar87 C&C eingefuegt: prtper INCR 0 $$$$$$$$$$*) + genln ("prtper INCR 0.0 ;"); + genln ("(* Um Warnung des ELAN-Compilers zu unterdruecken *)"). + (*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ENDE ZUSATZ $$$$$$$$$$$$$$$$$$$$$$$*) + get parameter : + next sym; + test bold (33); + get print param. + + get print param : + test (sym, tab pos, nil, nil, 32); + enter name. + + enter name : + TEXT VAR act param := sym; + INT VAR pos := scanposition - length (sym); + test subscript (act param, 33); + print param no INCR 1; + print param (print param no) := act param; + headline CAT text (subtext (print buf, pos, scanposition - 1), 13); + headline CAT " ". +END PROC generate init print; + +PROC test subscript (TEXT VAR act param, INT CONST err no) : + INT VAR tab pos; + next sym; + IF sym = "(" + THEN test index + FI. + + test index : + next sym; + act param CAT " SUB "; + act param CAT subscript; + next sym; + test closing bracket (sym); + next sym. + + subscript : + SELECT type OF + CASE number : trunc (sym) + CASE bold : search index + OTHERWISE : err (err no); nt + END SELECT. + + search index : + test (sym, tab pos, nil, for, 61); + sym. +END PROC test subscript; + +PROC generate init scale : + IF plot buf <> nt + THEN gen plot card + FI. + + gen plot card : + scale counter := 1; + plot param no := nil; + line no := plot line no; + cout (line no); + scan (plot buf); + REP + equal scale; + different scale + UNTIL type = eol OR sym = " " END REP; + generate scales. + + equal scale : + fixed scale := FALSE; + REP + next sym; + single scale param + UNTIL sym <> "," END REP. + + different scale : + IF sym = "/" + THEN scale counter INCR 1 + ELIF type <> eol + THEN err (sym, 26, plot line no) + FI. + + generate scales : + clear scales; + gen plot scales. + + gen plot scales : + FOR i FROM 1 UPTO plot param no REPEAT + gen (draw ad + "plot scale (""", id (i), """, ", + text (scale pointer (i))); + gen (", ", lower scale, ", ", upper scale); + gen (", ", text (l fixed scale (i)), ", ", text (u fixed scale (i))); + genln (");") + END REP. + + lower scale : + IF l fixed scale (i) + THEN lower bound (i) + ELSE "9.0e126" + FI. + + upper scale : + IF u fixed scale (i) + THEN upper bound (i) + ELSE "-9.0e126" + FI. + + clear scales : + FOR i FROM scale counter+1 UPTO plot param no REP + lower bound (i) := "0.0"; + upper bound (i) := "0.0" + PER. + + single scale param : + test bold (27); + enter plot param. + + enter plot param : + TEXT VAR param := sym; + test subscript (param, 22); + plot param no INCR 1; + IF plot param no > 10 + THEN err (64); + LEAVE generate init scale + FI; + plot name (plot param no) := param; + scalepointer (plot param no) := scalecounter; + set id; + set scale. + + set id : + IF sym = "=" + THEN next sym; + id (plot param no) := (sym SUB 1); + next sym + ELSE id (plot param no) := text (plot param no - 1) + FI. + + set scale : + IF sym = "(" + THEN get plot scale; + fixed scale := TRUE + ELIF NOT fixed scale + THEN l fixed scale (scale counter) := FALSE; + u fixed scale (scale counter) := FALSE; + FI. + + get plot scale : + IF fixed scale + THEN err (28) + FI; + read scale param (lower bound, l fixed scale, 29); + IF sym <> "," + THEN err (30) + FI; + read scale param (upper bound, u fixed scale, 30); + test closing bracket (sym); + next sym. +END PROC generate init scale; + +PROC read scale param (ROW 10 TEXT VAR bound, ROW 10 BOOL VAR fixed scale, + INT CONST err no) : + TEXT VAR scale; + INT VAR tab pos; + next sym; + IF type = bold + THEN test (sym, tab pos, nil, const, 61); + bound (scale counter) := sym; + fixed scale (scale counter) := TRUE + ELIF sym is number (scale) + THEN bound (scale counter) := scale; + fixed scale (scale counter) := TRUE + ELIF sym = "*" + THEN fixed scale (scale counter) := FALSE + ELSE err (err no) + FI; + next sym +END PROC read scale param; + +BOOL PROC sym is number (TEXT VAR constant) : + constant := nt; + IF sym IN "+-" + THEN constant := sym; next sym + FI; + IF type = number + THEN constant CAT sym; + TRUE + ELSE FALSE + FI +END PROC sym is number; + +PROC gen equations (INT CONST equ type) : + INT VAR i; + gen normal equs; + end of init list; + gen index equs. + + gen normal equs : + FOR i FROM tabbeg UPTO tabsize REP + IF is normal equ + THEN generate equ + FI + END REP. + + generate equ : + declare variables (i, equ type, FALSE). + + is normal equ : + CONCR (tab).type (i) = equ type + AND NOT CONCR (tab).rdef (i) AND CONCR (tab).index type (i) <= nil + AND NOT CONCR (tab).already used in loop body(i). + + gen index equs : + FOR i FROM tabbeg UPTO tabsize REP + IF is index equ + THEN gen loop (i, equ type) + FI + END REP. + + is index equ : + CONCR (tab).type (i) = equ type AND + NOT CONCR (tab).rdef (i) AND CONCR (tab).index type (i) > nil + AND NOT CONCR (tab).already used in loop body(i). + +END PROC gen equations; + +PROC gen loop (INT CONST i, equ type) : + for index := CONCR (tab).index (i); + TEXT VAR gen buf; + SELECT CONCR (tab).index type (i) OF + CASE bold : gen for loop + CASE number : generate replace + END SELECT. + + generate replace : + INT VAR k := i; + expression (equ type, gen buf, k); + gen replace (gen buf, k, text (for index)). + + gen for loop : + gen (" FOR ", CONCR (tab).name (for index), " FROM ", + CONCR (tab).init (for index)); + genln (" UPTO ", CONCR (tab).right part (for index), " REP"); + in loop := TRUE; + IF equ type = sub init + THEN gen replace (equ type, i) + ELSE search equal indices + FI; + in loop := FALSE; + genln (" PER;"). + + search equal indices : + INT VAR j; + FOR j FROM i UPTO tab size REP + IF is same index + THEN gen replace (equ type, j); + CONCR (tab).already used in loop body(j):=TRUE + FI + END REP. + + is same index : + for index = CONCR (tab).index (j) + AND CONCR (tab).index type (j) = bold + AND CONCR (tab).type (j) = CONCR (tab).type (i) + AND NOT CONCR (tab).rdef (j) + AND NOT CONCR (tab).already used in loop body(j). + +END PROC gen loop; + +PROC gen replace (TEXT VAR gen buf, INT CONST table index) : + gen replace (gen buf, table index, CONCR (tab).name (for index)) +END PROC gen replace; + +PROC gen replace (TEXT VAR gen buf, INT CONST table index, TEXT CONST index): + gen (" replace (", CONCR (tab).name (table index), ", ", index); + genln (", ", gen buf, ");") +END PROC gen replace; + +PROC gen replace (INT CONST equ type, tabpos) : + INT VAR no := tab pos; + TEXT VAR gen buf; + expression (equ type, gen buf, no); + gen replace (gen buf, no) +END PROC gen replace; + +PROC generate for variables : + is first := TRUE; + FOR i FROM tab beg UPTO tab size REP + IF CONCR (tab).type (i) = for + THEN gen for var + FI + END REP; + end of init list. + + gen for var : + set line no (i); + IF is first + THEN gen ("INT VAR "); + is first := FALSE + ELSE continue init list + FI; + gen (CONCR (tab).name (i)). +END PROC generate for variables; + +PROC generate variable part : + generate constants; + generate variables; + generate missed inits. + + generate constants : + INT VAR i; + FOR i FROM tab beg UPTO tabsize REP + IF CONCR (tab).type (i) = const AND NOT CONCR (tab).idef (i) + THEN gen const + FI + END REP. + + generate variables : + FOR i FROM tab beg UPTO tab size REP + SELECT CONCR (tab).type (i) OF + CASE level, aux, nequ, rate : gen normal equ + END SELECT + END REP. + + generate missed inits : + FOR i FROM tab beg UPTO tab size REP + SELECT CONCR (tab).type (i) OF + CASE aux, rate : gen missed init + END SELECT; + END REP; + end of init list. + + gen missed init : + IF sub init necessary + THEN declare variables (i, sub init, TRUE) + FI. + + sub init necessary : + CONCR (tab).init (i) = nt AND + NOT CONCR (tab).idef (i) AND CONCR (tab).index type (i) <= nil. + + gen normal equ : + IF equ not yet declared + THEN declare variables (i, nequ, TRUE) + FI. + + equ not yet declared : + NOT CONCR (tab).idef (i) AND CONCR (tab).init (i) <> nt + AND CONCR (tab).index type (i) <= nil. + + gen const : + gen linefeed; + gen (" "); + gen zz (i); + gen (CONCR (tab).name (i), " := ", "constant (""", CONCR (tab).name (i)); + gen (""", ", CONCR (tab).right part (i), ")"). +END PROC generate variable part; + +PROC end of init list : + IF NOT is first + THEN is first := TRUE; + genln (";") + FI +END PROC end of init list; + +PROC gen zz (INT CONST no) : + IF CONCR (tab).mac (no) > nil + THEN gen ("zz", CONCR(tab).name (CONCR(tab).mac (no)), text (expansion no)) + FI +END PROC gen zz; + +PROC declare variables (INT CONST no, equ type, BOOL CONST is init) : + INT VAR mac no := CONCR (tab).mac (no); + IF mac no > nil + THEN gen local equs + ELSE declare variable (no, equ type, is init) + FI. + + gen local equs : + INT VAR no of expansions := CONCR (tab).indextype (mac no); + FOR expansion no FROM 1 UPTO no of expansions REP + declare variable (no, equ type, is init) + END REP. +END PROC declare variables; + +PROC declare variable (INT CONST no, exp type, BOOL CONST init) : + TEXT VAR gen buf; + INT VAR i := no; + IF (init AND NOT CONCR (tab).idef (no)) OR + (NOT init AND NOT CONCR (tab).rdef (no)) + THEN gen equ + FI. + +gen equ : + expression (exp type, gen buf, i); + IF init + THEN gen linefeed + FI; + gen (" "); + gen zz (i); + gen (CONCR (tab).name (i), " := ", gen buf); + IF NOT init + THEN genln (";") + FI +END PROC declare variable; + +PROC gen linefeed : + IF is first + THEN is first := FALSE; + gen ("REAL VAR ") + ELSE continue init list + FI +END PROC gen linefeed; + +PROC set line no (INT CONST index) : + line no := CONCR (tab).line no (index); + cout (line no) +END PROC set line no; + +PROC continue init list : + genln (","); gen (" "); +END PROC continue init list; + +PROC gen tab var : + IF is first + THEN gen ("TAB VAR "); is first := FALSE + ELSE continue init list + FI +END PROC gen tab var; + +PROC generate table part : + is first := TRUE; + FOR i FROM tabbeg UPTO tabsize REP + SELECT CONCR (tab).type (i) OF + CASE table : gen tab declaration; + gen tab init + CASE aux, rate, level : IF CONCR (tab).index type (i) = bold + THEN + IF CONCR(tab).type(i)=aux THEN + IF NOT CONCR(tab).should declare vector(i) + THEN + find maximum index for current variable + FI; + IF CONCR(tab).should declare vector(i) + THEN + gen row init + FI + ELSE + gen row init + FI (*18.5.88 dc*) + FI + END SELECT + END REP; + end of init list. + +gen tab declaration : + gen tab var; + gen (CONCR (tab).name (i), " := vector (", vec length); + genln (");"); + is first := TRUE. + +gen tab init : + INT VAR elem no := 1; + scan (CONCR (tab).right part (i)); next sym; + set line no (i); + WHILE type is number REP + gen ("replace (", CONCR (tab).name (i), ", ", text (elem no)); + genln (", ", constant, ");"); + next sym; + elem no INCR 1 + UNTIL end of constant list END REP. + + type is number : + IF sym is number (constant) + THEN TRUE + ELSE err (40); FALSE + FI. + + end of constant list : + test delimiter. + + vec length : + INT VAR p, l := 1; + FOR p FROM 2 UPTO length (CONCR (tab).right part (i)) REP + IF (CONCR (tab).right part (i) SUB p) IN ",/" + THEN l INCR 1 + FI + PER; text (l). + + gen row init : + gen tab var; + gen (CONCR (tab).name (i), " := vector (", row length, ")"). + + row length : + set line no (i); + CONCR (tab).right part (CONCR (tab).index (i)). + + find maximum index for current variable: + INT VAR maximum, place, k; + TEXT VAR name::CONCR(tab).name(i); + maximum:=int(CONCR(tab).right part(CONCR(tab).index(i))); + place:=i; + FOR k FROM tabbeg UPTO tabsize REPEAT + check maximum of index and change if needed; + CONCR(tab).should declare vector(k):=FALSE + PER; + CONCR(tab).should declare vector(place):=TRUE. + +check maximum of index and change if needed: + IF same variable CAND need to change + THEN + maximum:=int(CONCR(tab).right part(CONCR(tab).index(k))); + place:=k + FI. + +need to change: + maximum < int(CONCR(tab).right part(CONCR(tab).index(k))). + +same variable: + name =CONCR(tab).name(k) CAND CONCR(tab).index type(k) = 1. + + +END PROC generate table part; + +BOOL PROC test delimiter : + SELECT pos ("/, EOL", sym) OF + CASE 1, 2 : next sym; FALSE + CASE 3, 4 : TRUE + OTHERWISE : err (62); TRUE + END SELECT +END PROC test delimiter; + +PROC generate table init : + INT VAR i, tab pos; + FOR i FROM tabbeg UPTO tabsize REP + IF CONCR (tab).index type (i) > nil AND NOT CONCR (tab).idef (i) + THEN gen tab init + FI + END REP. + + gen tab init : + SELECT CONCR (tab).type (i) OF + CASE nequ : gen loop (i, nequ) + CASE aux, rate : gen missed table init + CASE mac name : CONCR (tab).line no (i) := nil + END SELECT. + + gen missed table init : + search (CONCR (tab).name (i), tab pos, nil, nequ); + IF not found + THEN gen loop (i, sub init) + FI. +END PROC generate table init; + +PROC sort equ (INT CONST tab pos, equ type) : + IF in loop + THEN gen replace (equ type, tab pos) + ELSE declare variable (tab pos, equ type, equ type = nequ OR + equ type = sub init) + FI +END PROC sort equ; + +PROC expression (INT CONST equtype, TEXT VAR gen buf, INT VAR no) : + TEXT VAR symbol, buf := equation; + INT VAR spos := 1, stype, tabpos; + gen buf := nt; + set line no (no); + test global equ; + compile equ; + IF CONCR (tab).mac (no) = nil + COR expansion no >= CONCR (tab).index type (CONCR (tab).mac (no)) + THEN set def flag + FI. + + test global equ : + IF CONCR (tab).index type (no) < nil + THEN replace global mac param + FI. + + replace global mac param : + INT CONST param index := CONCR (tab).index (no); + search (actual parameter (CONCR (tab).rightpart (paramindex)), + tabpos, nil, nil); + no := tabpos; + expression (type of param, gen buf, no); + LEAVE expression. + + type of param : + IF equ type = sub init + THEN CONCR (tab).type (no) + ELSE equ type + FI. + + compile equ : + IF CONCR (tab).in use (no) + THEN err (CONCR (tab).name (no), 43) + ELSE pass expression + FI. + + pass expression : + CONCR (tab).in use (no) := TRUE; + expression2 (equtype, no, spos, stype, genbuf, symbol, buf); + CONCR (tab).in use (no) := FALSE. + + equation : + IF equtype = nequ + THEN CONCR (tab).init (no) + ELSE CONCR (tab).right part (no) + FI. + + set def flag : + SELECT equtype OF + CASE nequ, sub init : CONCR (tab).idef (no) := TRUE + CASE level : test level + OTHERWISE : CONCR (tab).rdef (no) := TRUE + END SELECT. + + test level : + IF CONCR (tab).init (no) = nt AND CONCR (tab).index type (no) = nil + THEN err (CONCR (tab).name (no), 39) + FI. +END PROC expression; + +PROC expression2 (INT CONST equtype, no, INT VAR spos, stype, + TEXT VAR gen buf, symbol, buf) : + next sym (buf, symbol, stype, spos); + REP + factor (equtype, no, spos, gen buf, buf, symbol, stype) + UNTIL is no operator END REP. + + is no operator : + IF symbol IN "+-*/" + THEN gen buf CAT symbol; + next sym (buf, symbol, stype, spos); + process obelix; + FALSE + ELSE TRUE + FI. + + process obelix : + IF symbol = "*" + THEN gen buf CAT symbol; + next sym (buf, symbol, stype, spos) + FI. +END PROC expression2; + +TEXT PROC actual parameter (TEXT CONST params) : + INT VAR position := nil, old position; + FOR i FROM 1 UPTO expansion no REP + old position := position; + position := pos (params, "%", position + 1) + END REP; + subtext (params, old position + 1, position - 1). +END PROC actual parameter; + +PROC factor (INT CONST equtype, no, INT VAR spos, TEXT VAR genbuf, + buf, symbol, INT VAR stype) : + BOOL VAR dollar := symbol = "$"; + INT VAR tab pos, mac num := CONCR (tab).mac (no); + IF dollar + THEN next sym (buf, symbol, stype, spos) + FI; + SELECT stype OF + CASE number : process number + CASE bold : process quantity + CASE delimiter : process delimiter + OTHERWISE : err (symbol, 44) + END SELECT. + + process number : + gen buf CAT symbol; + next sym (buf, symbol, stype, spos). + + process quantity : + TEXT VAR name := symbol, time script; + INT VAR old spos := spos; + next sym (buf, symbol, stype, spos); + IF mac num > nil + THEN search (name, tab pos, mac num, mac param); + IF not found + THEN search (name, tab pos, mac num, nil); + IF not found + THEN search (name, tab pos, nil, nil) + FI + FI + ELSE search (name, tab pos, nil, nil) + FI; + IF is global param + THEN search (name, tab pos, macro number of param, nil) + FI; + IF not found + THEN err (name, 46) + ELSE test type + FI. + + is global param : + not found AND CONCR (tab).index (no) > nil + AND CONCR (tab).index type (no) = nil. + + macro number of param : + CONCR (tab).mac (CONCR (tab).index (no)). + + test type : + INT VAR nop; + BOOL VAR is equ := FALSE; + search table entry; + get time script; + type := CONCR (tab).type (tab pos); + SELECT type OF + CASE std p : std function + CASE table : (* nanu *) + CASE mac param : replace param + CASE mac name : macro expansion + CASE const : constant + OTHERWISE test quantity + END SELECT; + IF symbol = "(" + THEN test index + ELIF is equ + THEN gen buf CAT name + FI. + + search table entry : + IF CONCR (tab).index type (tab pos) > nil AND + CONCR (tab).type (tab pos) = n equ + THEN search correct table; + IF not found + THEN err (name, 46); + LEAVE process quantity + FI + FI. + + search correct table : + not found := TRUE; + WHILE tab pos <> nil CAND table not found REP + tab pos := CONCR (tab).pred (tab pos) + END REP. + + table not found : + not found := NOT (CONCR (tab).name (tab pos) = name + AND not in macro AND type ok); + not found. + + not in macro : + CONCR (tab).mac (tab pos) = nil. + + type ok : + type := CONCR (tab).type (tab pos); + type = aux OR type = rate OR type = level. + + test quantity : + IF CONCR (tab).mac (tab pos) > nil + THEN name := "zz" + CONCR (tab).name (CONCR (tab).mac (tab pos)) + + text (expansion no) + name + FI; + is equ := TRUE; + SELECT equtype OF + CASE nequ : initialization + CASE aux : auxiliary + CASE level : level equation + CASE sub init: substitute init + CASE supp : supplementary + OTHERWISE : rate equation + END SELECT. + + get time script : + time script := nt; + IF symbol = "." + THEN next sym (buf, time script, stype, spos); + next sym (buf, symbol, stype, spos) + FI; + BOOL VAR is any := time script = any. + + replace param : + buf := text (buf, old spos - 2) + + actual param + subtext (buf, spos - 1); + spos := old spos - 1; + next sym (buf, symbol, stype, spos); + factor (equtype, no, spos, genbuf, buf, symbol, stype); + LEAVE factor. + + actual param : + TEXT VAR param := actual parameter (content); + IF param contains time script OR is number + THEN param + ELSE param + "." + any + FI. + + param contains time script : + (param SUB (length (param))) = any. + + is number : + pos ("0123456789", param SUB (length (param))) > 0. + + content : + IF type = nequ AND CONCR (tab).index (no) = nil + THEN CONCR (tab).init (tab pos) + ELSE CONCR (tab).right part (tab pos) + FI. + + test index : + gen buf CAT "("; + gen buf CAT name; + next sym (buf, symbol, stype, spos); + gen buf CAT " SUB "; + SELECT stype OF + CASE number : int index + CASE bold : var index + OTHERWISE : err (symbol, 48) + END SELECT; + test offset; + test closing bracket (symbol); + gen buf CAT symbol; + next sym (buf, symbol, stype, spos). + + test offset : + next sym (buf, symbol, stype, spos); + IF symbol IN "+-" + THEN pass offset + FI. + + pass offset : + gen buf CAT symbol; + next sym (buf, symbol, stype, spos); + gen buf CAT trunc (symbol); + IF stype <> number + THEN err (symbol, 48) + FI; + next sym (buf, symbol, stype, spos). + + int index : +(*IF CONCR (tab).index (no) <> int (symbol) + THEN err (symbol, 48); + message("Starten Sie trotzdem das übersetzte ELAN Programm") FI;*) +(*20.5.88 dc: hier kommt eine falsche Fehlermeldung *) + gen buf CAT trunc (symbol). + + var index : + search (symbol, tab pos, mac num, for); + gen buf CAT symbol; + IF incorrect index + THEN err (symbol, 48) + FI. + + incorrect index : + not found COR CONCR (tab).name (CONCR (tab).index (no)) <> symbol. + + std function : + test open bracket (symbol); + nop := length (CONCR (tab).right part (tab pos)); + gen buf CAT (name + " ("); + IF nop > nil + THEN pass actual params + ELSE next sym (buf, symbol, stype, spos); + test closing bracket (symbol) + FI; + next sym (buf, symbol, stype, spos); + IF act param <> nop + THEN err (symbol, 49) + FI. + + pass actual params : + INT VAR table pos := tab pos, act param := nil; + REP + act param INCR 1; + IF (CONCR (tab).right part (table pos) SUB act param) = "t" + THEN test if param is table + ELSE expression2 (equtype, no, spos, stype, gen buf, symbol, buf) + FI + UNTIL no more params END REP. + + no more params : + gen buf CAT symbol; + SELECT pos (",)", symbol) OF + CASE 1 : FALSE + CASE 2 : TRUE + OTHERWISE : err (symbol, 50); TRUE + END SELECT. + + test if param is table : + next sym (buf, symbol, stype, spos); + IF s type = bold + THEN search (symbol, tab pos, mac num, nil); + IF not found + THEN err (symbol, 51) + ELSE gen table + FI + ELSE err (symbol, 52) + FI. + + gen table : + IF CONCR (tab).type (tab pos) = table + THEN gen buf CAT symbol; + next sym (buf, symbol, stype, spos) + ELIF CONCR (tab).index type (tab pos) > nil + THEN factor (equtype, no, spos, genbuf, buf, symbol, stype) + ELSE err (symbol, 52) + FI. + + macro expansion : + CONCR (tab).line no (tab pos) INCR 1; + gen buf CAT "zz"; + gen buf CAT name; + gen buf CAT text (CONCR (tab).line no (tab pos)); + gen buf CAT name; + get actual parameters. + + get actual parameters : + TEXT VAR char; + test open bracket (symbol); + get macro parameter list; + next sym (buf, symbol, stype, spos). + + get macro parameter list : + REP + get act param + UNTIL end of parameter list END REP. + + end of parameter list : + SELECT pos (",)", char) OF + CASE 1 : FALSE + CASE 2 : TRUE + OTHERWISE : TRUE + END SELECT. + + get act param : + INT VAR brackets := nil; + char := buf SUB spos; + REP + spos INCR 1; + char := buf SUB spos + UNTIL end of param END REP; + spos INCR 1. + + end of param : + IF brackets = nil + THEN char IN ",)" + ELIF char = "(" + THEN brackets INCR 1; + FALSE + ELIF char = ")" + THEN brackets DECR 1; + FALSE + ELSE FALSE + FI. + + constant : + is equ := TRUE; + CONCR (tab).idef (tab pos) := TRUE. + + initialization : + IF time script = nt OR is any + THEN IF NOT CONCR (tab).idef (tab pos) + THEN IF CONCR (tab).init (tab pos) <> nt + THEN sort equ (tab pos, equ type) + ELIF is sub init + THEN sort equ (tab pos, sub init) + ELSE err (symbol, 39) + FI + FI + ELSE err (time script, 56) + FI. + + is sub init : + CONCR (tab).init (tab pos) = nt AND correct type (type). + + auxiliary : + IF time script = aux time script OR is any + THEN IF NOT CONCR (tab).rdef (tab pos) AND type = aux + THEN sort equ (tab pos, equtype) + FI + ELSE err (time script, 57) + FI. + + aux time script : + SELECT type OF + CASE aux, level : "k" + CASE rate : "jk" + OTHERWISE : " " + END SELECT. + + level equation : + IF time script <> level time script AND NOT is any + THEN err (time script, 59) + FI. + + level time script : + SELECT type OF + CASE aux, level : "j" + CASE rate : "jk" + OTHERWISE : " " + END SELECT. + + rate equation : + IF time script <> rate time script AND NOT is any + THEN err (time script, 60) + FI. + + rate time script : + SELECT type OF + CASE aux, level : "k" + CASE rate : "jk" + OTHERWISE : " " + END SELECT. + + supplementary : + IF time script <> supp time script AND NOT is any + THEN err (time script, 57) + FI. + + supp time script : + SELECT type OF + CASE aux, level, supp : "k" + CASE rate : "jk" + OTHERWISE : " " + END SELECT. + + substitute init : + IF NOT CONCR (tab).idef (tab pos) + THEN gen sub init equ + FI. + + gen sub init equ : + IF CONCR (tab).index type (tab pos) > nil + THEN IF CONCR (tab).index type (no) = nil + THEN process index equ + FI + ELIF CONCR (tab).init (tab pos) = nt + THEN IF correct type (type) + THEN sort equ (tab pos, equtype) + FI + ELSE sort equ (tab pos, nequ) + FI. + + process index equ : + INT VAR table type := sub init; + IF type <> nequ + THEN search nequ + FI; + IF NOT CONCR (tab).idef (tab pos) AND correct type (type) + THEN end of init list; + gen loop (tab pos, table type); + CONCR (tab).idef (tab pos) := TRUE + FI. + + search nequ : + search (CONCR (tab).name (tabpos), table pos, nil, nequ); + IF NOT (not found CAND CONCR (tab).idef (tab pos)) + THEN type := nequ; + tab pos := table pos; + table type := type + FI. + + process delimiter : + genbuf CAT symbol; + SELECT pos ("(+-", symbol) OF + CASE 1 : process bracket + CASE 2, 3: process monadic operator + OTHERWISE err (symbol, 44) + END SELECT. + + process bracket : + expression2 (equtype, no, spos, stype, genbuf, symbol, buf); + test closing bracket (symbol); + gen buf CAT symbol; + next sym (buf, symbol, stype, spos); + IF symbol = "(" + THEN gen buf CAT "*"; + factor (equtype, no, spos, gen buf, buf, symbol, stype) + FI. + + process monadic operator : + next sym (buf, symbol, stype, spos); + factor (equtype, no, spos, gen buf, buf, symbol, stype). +END PROC factor; + +BOOL PROC correct type (INT CONST equ type) : + SELECT equ type OF + CASE aux, rate, nequ : TRUE + OTHERWISE : FALSE + END SELECT. +END PROC correct type; + +TEXT PROC draw ad: + IF is draw THEN "b" ELSE "" END IF +END PROC draw ad; + +(*$$$$$$$$$$$$$$$ ZUSATZ Februar 87 C&C geaendert: Ausgabe "dump" $$$$$$$$*) + +(* In dieser Prozedur wird eine Datei 'dump' angelegt, in der alle *) +(* Dynamo-Standardfunktionen, Macros und die programmspezifischen *) +(* Variablen und Konstanten eingetragen werden. *) + +PROC table dump : +IF exists ("dump") +THEN forget("dump",quiet) +FI; +FILE VAR dump := sequential file(output, "dump"); +sysout("dump"); + FOR i FROM 1 UPTO CONCR (tab).tab size REP + put (i); + put ("NAM :"); put (CONCR (tab).name (i)); + put ("RP :"); put (CONCR (tab).right part (i)); + put ("INI :"); put (CONCR (tab).init (i)); + put ("IND :"); put (CONCR (tab).index (i)); + put ("IT :"); put (CONCR (tab).index type (i)); + put ("TYP :"); put (CONCR (tab).type (i)); + line; + END REP; +sysout("") +END PROC table dump +(*$$$$$$$$$$$$$$$$$$$$ ENDE ZUSATZ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$*) +END PACKET dynamo compiler 33 + diff --git a/lang/dynamo/1.8.7/src/dyn.abnahme b/lang/dynamo/1.8.7/src/dyn.abnahme new file mode 100644 index 0000000..e8c100d --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.abnahme @@ -0,0 +1,19 @@ +NOTE +NOTE Ein einfaches Modell der Bevoelkerungsentwicklung +NOTE +L BEVOELKERUNG.K=BEVOELKERUNG.J+DT*(GEBURTENRATE.JK-STERBERATE.JK) +N BEVOELKERUNG=1000 +R GEBURTENRATE.KL=BEVOELKERUNG.K*WACHSTUMSFAKTOR +N GEBURTENRATE=10 +C WACHSTUMSFAKTOR=0.01 das heisst: 1 Prozent +R STERBERATE.KL=BEVOELKERUNG.K*STERBEFAKTOR +C STERBEFAKTOR=0.001 das heisst: 1 Promille +N STERBERATE=10 +NOTE +NOTE Simulationsparameter +NOTE +PLOT BEVOELKERUNG=B(0,2000)/GEBURTENRATE=G(0,40)/STERBERATE=S(0,6) +C DT=1 +C PLTPER=1 +C LENGTH=68 + diff --git a/lang/dynamo/1.8.7/src/dyn.bev b/lang/dynamo/1.8.7/src/dyn.bev new file mode 100644 index 0000000..5b759d3 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.bev @@ -0,0 +1,50 @@ +NOTE EIN BEVÖLKERUNGSMODELL DER BUNDESREPUBLIK DEUTSCHLAND +NOTE +NOTE ANGABEN DER GEBURTENRATEN (GR) UND STERBEQUOTIENTEN (SQ) +NOTE AUS DEM STATISTISCHEN JAHRBUCH 1982 +NOTE +FOR LJ=1,80 LEBENSJAHRE +FOR LJ2=2,80 +L BEV.K(1)=BEV.J(1)+DT*(GB.J-A.J(1)-S.J(1)) BABIES +L BEV.K(LJ2)=BEV.J(LJ2)+DT*(A.J(LJ2-1)-A.J(LJ2)-S.J(LJ2)) BEVÖLKERUNG +A A.K(LJ)=(1-SQ(LJ))*BEV.K(LJ) +A S.K(LJ)=SQ(LJ)*BEV.K(LJ) +A GB.K=SCLPRD(BEV.K,15,44,GR,1)/2 Geburten +A GBEV.K=SUM(BEV.K) Gesamtbevölkerung +A ZBEV.K=SUMV(BEV.K,16,59) zahlende Bevölkerung (in Rentenversicherung) +A PRENT.K=SUMV(BEV.K,60,80) potentielle Rentner +NOTE +N BEV(LJ)=IBEV(LJ)*1E3 +T IBEV= +X 584/585/590/609/652/728/780/843/927/980/ +X 1014/1032/1045/1049/1024/1003/986/959/929/903/ +X 884/857/850/845/841/844/854/872/854/810/ +X 756/676/722/826/829/905/1029/1062/1026/968/ +X 934/919/884/783/711/725/763/784/784/768/ +X 742/744/724/700/716/751/765/673/488/385/ +X 397/479/613/690/698/681/664/666/654/630/ +X 603/573/546/510/476/445/402/359/320/1681 +NOTE +T SQ= +X .01965/.00123/.00082/.00082/.00082/.00055/.00055/.00055/.00055/.00055/ +X .00033/.00033/.00033/.00033/.00033/.00064/.00064/.00064/.00064/.00064/ +X .00183/.00183/.00183/.00183/.00183/.00131/.00131/.00131/.00131/.00131/ +X .00152/.00152/.00152/.00152/.00152/.00193/.00193/.00193/.00193/.00193/ +X .00302/.00302/.00302/.00302/.00302/.00497/.00497/.00497/.00497/.00497/ +X .00750/.00750/.00750/.00750/.00750/.01220/.01220/.01220/.01220/.01220/ +X .01868/.01868/.01868/.01868/.01868/.03146/.03146/.03146/.03146/.03146/ +X .05206/.05206/.05206/.05206/.05206/.08241/.08241/.08241/.08241/.175 +NOTE +T GR= +X .0008/.0041/.0138/.0274/.0453/.0597/.0745/.0861/.0933/.1025/ +X .1067/.1074/.1050/.0963/.0872/.0753/.0642/.0531/.0430/.0360/ +X .0297/.0225/.0184/.0144/.0114/.0087/.0063/.0044/.0031/.0020 +NOTE +C DT=1 +C PLTPER=1 +C PRTPER=1 +N TIME=1982 +C LENGTH=2000 +NOTE PRINT GB,A(1),S(1),BEV(1),BEV(2),GR(1),GR(15),GR(30) +PRINT GBEV,BEV(1),BEV(40),BEV(60),BEV(63),BEV(65),ZBEV,PRENT + diff --git a/lang/dynamo/1.8.7/src/dyn.cob b/lang/dynamo/1.8.7/src/dyn.cob new file mode 100644 index 0000000..eabb1b8 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.cob @@ -0,0 +1,19 @@ +NOTE COBWEB MODEL 27.11.81 +L PREIS.K=PREIS.J+(DT)*K*(NACHFR.J-ANGEBOT.J) +L ANGEBOT.K=A+B*PREIS.J +A NACHFR.K=C-D*PREIS.K +NOTE B>0, D>0, K>0 +N PREIS=0 +N ANGEBOT=11 +C K=1 +C A=1. +C B=.9 +C C=12.4 +C D=1.2 +C DT=.1 +C LENGTH=10 +C PRTPER=.1 +C PLTPER=.1 +PLOT PREIS=P/NACHFR=N(1,10)/ANGEBOT=A +PRINT PREIS,ANGEBOT,NACHFR + diff --git a/lang/dynamo/1.8.7/src/dyn.const b/lang/dynamo/1.8.7/src/dyn.const Binary files differnew file mode 100644 index 0000000..c42ad1c --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.const diff --git a/lang/dynamo/1.8.7/src/dyn.delaytest b/lang/dynamo/1.8.7/src/dyn.delaytest new file mode 100644 index 0000000..c475433 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.delaytest @@ -0,0 +1,8 @@ +NOTE GOODMAN S.248 +A Y.K=DELAY3(X,D) +C D=50 +R X.KL=TABLE(XT,TIME.K,0,125,25) +T XT=0/10/0/-10/0/10 +PLOT X=X,Y=Y(-10,10) +SPEC DT=0.5,LENGTH=125,PLTPER=2 + diff --git a/lang/dynamo/1.8.7/src/dyn.errors b/lang/dynamo/1.8.7/src/dyn.errors new file mode 100644 index 0000000..64a4f27 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.errors @@ -0,0 +1,68 @@ +gleichung doppelt definiert +doppelte initialisierung +falscher zeilentyp +verschachtelte makro-definition +makro-name erwartet +'(' erwartet +formaler parameter erwartet +')' nach parameterliste erwartet +bei auxiliaries nur subskription mit '.k' erlaubt +bei konstanten-definition name erwartet +bei levels nur subskription mit '.k' erlaubt +bei rates nur subskription mit '.kl' erlaubt +bei table-definition keine subskription erlaubt +x - befehl hier nicht erlaubt +bei for-definition name erwartet +'=' nach for-variable erwartet +bereichsangabe erwartet +',' erwartet +lokale gleichung nur in makro erlaubt +bei definition name erwartet +'=' erwartet +index nicht korrekt +')' nach indizierung erwartet +prtper nicht definiert +pltper nicht definiert +'/' oder ',' bei plot erwartet +name als plotparameter erwartet +doppelte scale-angabe in einer gruppe +erste scale-angabe erwartet +zweite scale-angabe erwartet +')' nach scale-angabe erwartet +printparameter nicht definiert +printparameter erwartet +time darf nur initialisiert werden +dt nicht definiert +length nicht definiert +bei konstanten-definition zahl erwartet +bei initialisierung konstante erwartet +levels muessen initialisiert werden +konstante bei table erwartet +'/' oder ',' erwartet +table-definition ohne benutzung +simultane gleichungen +faktor erwartet +time muss mit '.j' oder '.k' subskribiert werden +symbol nicht definiert +funktion nicht definiert +unzulaessige indizierung +falsche parameteranzahl +falsches trennsymbol zwischen parametern +als parameter table erwartet +falscher parameter in tablefunktion +zuviele aktuelle parameter +')' nach makroaufruf fehlt +rekursiver makroaufruf +bei n-gleichung keine subskription erwartet +falsche subskription in auxiliary-gleichung +')' erwartet +falsche subskription in level-gleichung +falsche subskription in rate-gleichung +for-variable nicht definiert +konstante erwartet +falsches real-format +zu viele plot-parameter +bei run-befehl dateiname erwartet +als noise-parameter zahl erwartet +plot- und draw-Anweiungen dürfen im Programm nicht gemischt werden + diff --git a/lang/dynamo/1.8.7/src/dyn.forest b/lang/dynamo/1.8.7/src/dyn.forest new file mode 100644 index 0000000..5075925 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.forest @@ -0,0 +1,47 @@ +NOTE 23.04.1985 english version 22.11.1985 +note forest management model +note +note wood standing within the forest +l wood.k=wood.j+dt*(woodgrowth.jk-harvest.jk) +n wood=startingwood +c startingwood=15000 m**3 +r woodgrowth.kl=wood.k*stocksfactor*cultivationfactor.k +c stocksfactor=0.04 growth in % of wood +a cultivationfactor.k=tabhl(tclfactor,clstate.k,0,1,0.1) +t tclfactor=0/.1/.2/.3/.4/.5/.7/.95/1/1.05/1.2 +r harvest.kl=wood.k*harvestpercent.k*0.1 +a harvestpercent.k=tabhl(tharvestpercent,ratio1.k,0.8,1.2,0.1) +t tharvestpercent=0.1/0.3/0.35/0.4/0.6 +a ratio1.k=wood.k/maxstock +c maxstock=16000 +note +note resources +l resources.k=resources.j+dt*(income.jk-clexpense.jk-draw.jk) +n resources=startresources +c startresources=100000 money units +r income.kl=wood.k*harvestpercent.k*0.1*price +c price=190 money units per cubic m +r clexpense.kl=resources.k-constdraw +r draw.kl=constdraw +c constdraw=20000 +note +note cultivationstate (clstate; dimensionless ) +l clstate.k=clstate.j+dt*(clbetter.jk-clworse.jk) +n clstate=startclstate +c startclstate=0.8 +r clbetter.kl=clbetterfactor.k*(1-clstate.k) +a clbetterfactor.k=tabhl(tclbetter,cultivationcost.k,80000,180000,100000) +t tclbetter=0.0/0.1 +a cultivationcost.k=resources.k-constdraw +r clworse.kl=clworsefactor.k*clstate.k +a clworsefactor.k=tabhl(tclworse,cultivationcost.k,0,80000,80000) +t tclworse=0.2/0 +note +note +print wood,resources,clstate +plot wood=w/resources=r/clstate=c(0,1) +c dt=1 +c length=50 +c prtper=1 +c pltper=1 + diff --git a/lang/dynamo/1.8.7/src/dyn.forst7 b/lang/dynamo/1.8.7/src/dyn.forst7 new file mode 100644 index 0000000..d767a50 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.forst7 @@ -0,0 +1,76 @@ +#papersize(20.5,61.0)# +#pagelength(59.0)# +#type("picac")# +NOTE 25.04.1985 14.30 +note forstbetriebsmodell +note +note stehender Holzvorrat +l holz.k=holz.j+dt*(zuwachs.jk-ernte.jk) +n holz=startholz +c startholz=15000 Angabe in Festmetern(fm) +r zuwachs.kl=holz.k*vorratsfaktor*pflegefaktor.k +c vorratsfaktor=0.035 Zuwachs in % von holz +a pflegefaktor.k=tabhl(tpffaktor,pfzustand.k,0,1,0.1) +t tpffaktor=.7/.7/.7/.7/.7/.8/.9/.95/1/1.05/1.2 +r ernte.kl=ernte1.k +a ernte1.k=holz.k*ernteproz.k*ernteprozfak.k +a ernteproz.k=tabhl(ternproz,ratio1.k,0.5,1.2,0.1) +t ternproz=0.02/0.025/0.03/0.03/0.03/0.035/0.06/0.08 +a ratio1.k=holz.k/maxvorrat +c maxvorrat=16000 +note +note resourcen +l resourcen.k=resourcen.j+dt*(einnahme.jk-eig.jk-pfausgaben.jk) +n resourcen=startresourcen +c startresourcen=100000 Geldeinheiten +c preis=190 Geldeinheiten pro fm +r einnahme.kl=ernte1.k*preis +r pfausgaben.kl=resourcen.k-eigenent.k +r eig.kl=eigenent.k +a anpassungsfaktor.k=tabhl(tanpass,ratio2.k,0.5,1.5,0.1) +t tanpass=.5/.55/.6/.7/.9/1/1/1/1.1/1.2/1.3 +l eigenent.k=min(eigenent.j*anpass.jk,resourcen.j) +r anpass.kl=anpassungsfaktor.k +n eigenent=eigenentstart +c eigenentstart=20000 +note +note arbeitseinheiten +note +l arbeit.k=arbeit.j+dt*(pfausgaben.jk/preisae-arbeitsverbrauch.jk) +n arbeit=startarbeit +c startarbeit=800 +c preisae=100 ( preis pro arbeitseinheit in geldeinheiten ) +r arbeitsverbrauch.kl=min(arbeit.k,notwarbeit.k) +a notwarbeit.k=tabhl(tnotwarb,pfzustand.k,0.0,1.0,0.1) +t tnotwarb=1600/1550/1500/1450/1400/1300/1150/950/800/700/600 +a ratio2.k=arbeit.k/notwarbeit.k +a ernteprozfak.k=tabhl(ternteprozfak,ratio2.k,0.2,1.6,0.2) +t ternteprozfak=.4/.5/1/2/1.05/1/.9/.7 +note +note Pflegezustand (pfzustand; dimensionslose Größe) +l pfzustand.k=pfzustand.j+dt*(pfverbess.jk-pfversch.jk) +n pfzustand=startpfzustand +c startpfzustand=0.8 +r pfverbess.kl=smooth(pfx1.k,pfverzoeg) +a pfx1.k=pfverbfaktor.k*(1-pfzustand.k) +a pfverbfaktor.k=tabhl(tpfverb,ratio2.k,.8,1.4,.2) +t tpfverb=0/0/.1/0.2 +r pfversch.kl=smooth(pfverschfaktor.k*pfzustand.k,pfverzoeg) +c pfverzoeg=2 +a pfverschfaktor.k=tabhl(tpfversch,ratio2.k,0,.8,.2) +t tpfversch=.4/.2/.1/.05/0 +note +note +note print ratio1,ratio2,eigenent,arbeit,pfzustand +plot holz=h(1e4,2e4)/eigenent=e(0,2e5)/pfzustand=P(0,1)/ratio2=2(0,5) +c dt=1 +c length=50 +note prtper=1 +c pltper=1 +run dyn.forst7 + + + + + + diff --git a/lang/dynamo/1.8.7/src/dyn.gekoppeltependel b/lang/dynamo/1.8.7/src/dyn.gekoppeltependel new file mode 100644 index 0000000..3f2a961 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.gekoppeltependel @@ -0,0 +1,19 @@ +NOTE gekoppelte pendel +L x1.k=x1.j+dt*v1.j +L x2.k=x2.j+dt*v2.j +L v1.k=v1.j+dt*(-d0/m1*x1.j-(d/m1)*(x1.j-x2.j)) +L v2.k=v2.j+dt*(-d0/m2*x2.j-(d/m2)*(x2.j-x1.j)) +N x1=a +N x2=0 +N v1=0 +N v2=0 +C a=3 +C m1=2 +C m2=2 +C d0=9 +C d=2 +C dt=0.1 +C length=50 +C pltper=0.3 +PLOT x1=1(-3,9)/x2=2(-9,3) + diff --git a/lang/dynamo/1.8.7/src/dyn.grashasenfuchs b/lang/dynamo/1.8.7/src/dyn.grashasenfuchs new file mode 100644 index 0000000..046a1e1 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.grashasenfuchs @@ -0,0 +1,42 @@ +NOTE +NOTE Raeuber-Beute-Beziehung nach VOLTERRA am Beispiel Fuchs-Hase +NOTE Aenderung: mit FUTTER und CLIP-Funktion +L GRAS.K=CLIP(GRAS.J+DT*(WACHSR.JK-FRESSR.JK),0,GRAS.J,0) +L HASEN.K=CLIP(HASEN.J+DT*(HGRATE.JK-HSRATE.JK),0,HASEN.J,0) +L FUECHS.K=CLIP(FUECHS.J+DT*(FGRATE.JK-FSRATE.JK),0,FUECHS.J,0) +R WACHSR.KL=(GPROZ/100)*GRAS.K GPROZ Wachstumsprozente +R FRESSR.KL=GFRESS*HASEN.K*GRAS.K GFRESS in: pro Hasen +R HGRATE.KL=HGK*HASEN.K*GRAS.K +R HSRATE.KL=TREFF*HASEN.K*FUECHS.K+HSTIRB*HASEN.K +R FGRATE.KL=FGK*HASEN.K*FUECHS.K +R FSRATE.KL=FSK*FUECHS.K +NOTE +NOTE Gleichgewichtsbedingungen: +NOTE HASEN=GPROZ/(100*Gfress) +NOTE +NOTE Hasengeburtenkoeffizient*GRAS=Trefferwahrscheinlichkeit*Fuechse +NOTE +Hstirb +NOTE Fuechsesterbekoeffizient=Fuechsegeburtenkoeffizient*Hasen +NOTE +N GRAS=IG +N HASEN=IH +N FUECHS=IF +C GPROZ=3 Graswachstum 3% +C GFRESS=3E-4 (Grasfressanteil) pro Hasen +C HGK=1E-3 Hasengeburtskoeff +C TREFF=4E-2 Trefferwahrscheinlichkeit +C HSTIRB=0.001 Hasensterbekoeffizient (ohne Fuechse) +C FGK=0.05 Fuechsegeburtenkoeffizient +C FSK=5 Fuechsesterbekoeffizient +C IG=1E+3 +C IH=110 +C IF=25 +NOTE +NOTE SIMULATIONSPARAMETER +NOTE +C DT=0.083 +C PLTPER=.083 monatlich, 0.083=1/12 ! +C LENGTH=5 +PLOT GRAS=G(995,1005)/HASEN=H(85,115)/FUECHS=F(15,35) + + diff --git a/lang/dynamo/1.8.7/src/dyn.help b/lang/dynamo/1.8.7/src/dyn.help new file mode 100644 index 0000000..e4f82c0 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.help @@ -0,0 +1,24 @@ + Im Dynamo Runtime-System stehen folgende Kommandos + zur Verfügung (Verlassen dieser Erklärung mit <ESC> q) : + + run ...................... Ausführen des übersetzten Programms + + c <Konstantenname>=Wert .. Änderung einer oder mehrerer Konstanten + + ? ........................ Anzeige der Konstanten und ihrer Werte + + quit ..................... Verlassen des Runtime-Systems + + help ..................... Zeigt diese Erklärungen + + + Bei PRINT oder PLOT - Ausgaben sind folgende Kommandos möglich : + + + ....................... Nächster Bildschirm + + o ....................... (Off), keine Unterbrechung der Ausgabe + + e ....................... (End), Zurück zum Runtime-System + + <ESC> .................... Abbruch der Ausgabe + diff --git a/lang/dynamo/1.8.7/src/dyn.inserter b/lang/dynamo/1.8.7/src/dyn.inserter new file mode 100644 index 0000000..4b0b9d5 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.inserter @@ -0,0 +1,54 @@ +put line ("DYNAMO 3.3+ wird generiert"); +line; +WHILE noch nicht alle dateien da REPEAT (* Christian Szymanski *) + hole dateien vom archiv (* 10.08.88 *) +END REPEAT; +putline ("Die Pakete werden insertiert."); +putline ("Bitte warten !"); +checkoff; +IF id(0) < 182 + THEN insert ("dyn.kleiner182") +FI ; +insert ("dyn.tool"); +insert ("dyn.33"); +insert ("dyn.vec"); +insert ("dyn.proc"); +insert ("dyn.rts"); +insert ("dyn.plot+"); +insert ("dyn.plot"); +insert ("dyn.print"); +command dialogue (TRUE); +do ("init errors (""dyn.errors"")"); +do ("init std (""dyn.std"")"); +do ("insert macro (""dyn.mac"")"); +do ("graphic (yes (""mit CGA-Grafik""))"); +putline ("dynamo-system generiert"); +check on. + +noch nicht alle dateien da: + THESAURUS VAR alle dateien := empty thesaurus; + IF id(0) < 182 THEN + insert (alle dateien,"dyn.kleiner182") + FI ; + insert (alle dateien, "dyn.tool"); + insert (alle dateien, "dyn.33"); + insert (alle dateien, "dyn.vec"); + insert (alle dateien, "dyn.proc"); + insert (alle dateien, "dyn.rts"); + insert (alle dateien, "dyn.plot+"); + insert (alle dateien, "dyn.plot"); + insert (alle dateien, "dyn.print"); + highest entry (alle dateien - all) > 0 . + +hole dateien vom archiv: + IF yes ("DYNAMO-Diskette eingelegt") THEN + archive ("dynamo"); + fetch (ALL archive - all, archive); + release (archive) + FI. + + + + + + diff --git a/lang/dynamo/1.8.7/src/dyn.mac b/lang/dynamo/1.8.7/src/dyn.mac new file mode 100644 index 0000000..03a0f9f --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.mac @@ -0,0 +1,44 @@ +macro delay1(in,del) +a delay1.k=$lv.k/del +l $lv.k=$lv.j+dt*(in.jk-delay1.j) +n $lv=del*in +mend +macro delay3(in,del) +a $dl.k=del/3 +l $lv3.k=$lv3.j+dt*($rt2.jk-delay3.j) +n $lv3=$dl*in +r $rt2.kl=$lv2.k/$dl.k +l $lv2.k=$lv2.j+dt*($rt1.jk-$rt2.jk) +n $lv2=$lv3 +r $rt1.kl=$lv1.k/$dl.k +l $lv1.k=$lv1.j+dt*(in.jk-$rt1.jk) +n $lv1=$lv3 +a delay3.k=$lv3.k/$dl.k +mend +macro delay3p(in,del,ppl) +a delay3p.k=$lv3.k/$dl.k +l $lv3.k=$lv3.j+dt*($rt2.jk-delay3p.j) +n $lv3=$dl*in +r $rt2.kl=$lv2.k/$dl.k +l $lv2.k=$lv2.j+dt*($rt1.jk-$rt2.jk) +n $lv2=$lv3 +r $rt1.kl=$lv1.k/dl.k +l $lv1.k=$lv1.j+dt*(in.jk-$rt1.jk) +n $lv1=$lv3 +a $dl.k=del/3 +a ppl.k=$lv3.k+$lv2.k+$lv1.k +mend +macro dlinf3(in,del) +l dlinf3.k=dlinf3.j+dt*($lv2.j-dlinf3.j)/$dl.j +n dlinf3=in +l $lv2.k=$lv2.j+dt*($lv1.j-$lv2.j)/$dl.j +n $lv2=in +l $lv1.k=$lv1.j+dt*(in.j-$lv1.j)/$dl.j +n $lv1=in +a $dl.k=del/3 +mend +macro smooth(in,del) +l smooth.k=smooth.j+dt*(in.j-smooth.j)/del +n smooth=in +mend + diff --git a/lang/dynamo/1.8.7/src/dyn.mehreredelays b/lang/dynamo/1.8.7/src/dyn.mehreredelays new file mode 100644 index 0000000..6eac8fe --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.mehreredelays @@ -0,0 +1,9 @@ +NOTE GOODMAN S.248 +A Y.K=DELAY3(X,D) +A Z.K=DELAY3(Y,D) +C D=50 +R X.KL=TABLE(XT,TIME.K,0,125,25) +T XT=0/10/0/-10/0/10 +PLOT X=X,Y=Y,Z=Z(-10,10) +SPEC DT=0.5,LENGTH=125,PLTPER=2 + diff --git a/lang/dynamo/1.8.7/src/dyn.natchez b/lang/dynamo/1.8.7/src/dyn.natchez new file mode 100644 index 0000000..e62c70d --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.natchez @@ -0,0 +1,14 @@ +NOTE Heiratsregeln der NATCHEZ Indianer +L SUN.K=SWITCH(0,SUN.J,STINKARD.J) +L NOBLE.K=SWITCH(0,NOBLE.J+SUN.J,STINKARD.J) +L HONORED.K=SWITCH(0,HONORED.J+NOBLE.J,STINKARD.J) +L STINKARD.K=CLIP(STINKARD.J-NOBLE.J,0,STINKARD.J-NOBLE.J,0) +N SUN=20 +N NOBLE=10 +N HONORED=10 +N STINKARD=3000 +C DT=1 +C LENGTH=17 +C PLTPER=1 +PLOT SUN=*,NOBLE=N,HONORED=H,STINKARD=S + diff --git a/lang/dynamo/1.8.7/src/dyn.oszillator b/lang/dynamo/1.8.7/src/dyn.oszillator new file mode 100644 index 0000000..3f1e815 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.oszillator @@ -0,0 +1,26 @@ +NOTE OSZILLATOR +L X.K=X.J+Y.J*DT +N X=2 +L Y.K=(Y.J+DT*(F/M-X.J*OMEGANULLQUADRAT.J))/(1+GAMMA.J*DT) +N Y=3 +C M=5 +NOTE +NOTE linearer harmonischer Oszillator mit BETA=0 und F=0 +NOTE +NOTE gedaempfter Oszillator mit BETA<>0 und F=0 +NOTE +NOTE allgemeiner Oszillator mit BETA<>0 und F=f(TIME) +C BETA=0.5 +A GAMMA.K=BETA/M +C F=0 +C K=1 +A OMEGANULLQUADRAT.K=K/M +NOTE hier heisst eine Konstante"K". DYNAMO verwechselt das nicht mit .K !! +C DT=0.01 +NOTE DT WIRD EXTRA SO KLEIN GEWAEHLT; DAMIT DIE ANNAEHERUNG GUT IST +NOTE +NOTE DAS GEHT AUF KOSTEN DER RECHENZEITEN !!! +C LENGTH=68 +C PLTPER=1 +PLOT Y + diff --git a/lang/dynamo/1.8.7/src/dyn.plot b/lang/dynamo/1.8.7/src/dyn.plot new file mode 100644 index 0000000..fe1228a --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.plot @@ -0,0 +1,235 @@ +PACKET dynamo plotter (* Änder.: C.Szymanski, 21.07.88 *) + DEFINES b initialize plot, b new plot line, b plot, b end of program, + b plot scale : + +LET maxvalue = 200, + valuepagelength = 18, + max param numb = 10; + +TYPE PLOTPARAM = STRUCT (TEXT name, id, + INT scale pointer, + REAL lower bound, upper bound, + BOOL l fixed scale, u fixed scale); + +ROW max param numb PLOTPARAM VAR plotparam;(* Enth. Plotparameter *) +ROW maxvalue REAL VAR value; (* Ausgabepuffer *) +ROW max param numb ROW 5 REAL VAR scale; (* Enth. errechnete Skalierungen *) + +BOOL VAR plt; +TEXT VAR headline; +REAL VAR pltper, nextplot; +INT VAR value no, param no, plot line no, + plot param no, line no; +INT CONST nil := 0; + +LET line1 = ".____________.____________.____________.____________.", + line2 = ". . . . ."; + +PROC plot one page : + init plot routine; + plot values. + + init plot routine : + print suppressed output; + plot line no := nil. + + plot values : + INT VAR act value := 1, i; + TEXT VAR plot buf; + line; + vdt; + line; + IF b stop request THEN LEAVE plot one page END IF; + sys page; + plot output (headline); + put scales; + WHILE act value < value no REP + put time; + gen line; + FOR i FROM 1 UPTO plot param no REP + plot single value + END REP; + plot output (plot buf + line0 + collision); + plot line no INCR 1; + act value INCR plot param no; + act value INCR 1 + END REP. + + put time : + plot buf := text (text (round (value (act value), 2)), 6). + (* Erstes Pufferelement enthaelt time *) + + gen line : + TEXT VAR line0, collision := ""; + line0 := act line. + + act line : + IF (plot line no MOD 5) = nil (* Prueft, ob gestrichelte oder durch - *) + THEN line1 (* gezogene Linie gedruckt wird *) + ELSE line2 + FI. + + plot single value : + INT VAR position := int ((x-low)*53.0/(up-low))+1; (*Interpolationsformel*) + position := limit; + IF pos ("._ ", line0 SUB position) > nil + THEN replace (line0, position, plotparam (i).id) + ELSE collision CAT plotparam (i).id + FI. + + limit : + IF position > 53 + THEN 53 + ELIF position < 1 + THEN 1 + ELSE position + FI. + + up : + scale (i) (5). (* Oberer Grenzwert (der Skalierung) *) + + low : + scale (i) (1). (* Unterer Grenzwert *) + + x : + value (act value + i). + + put scales : (* Gibt Skalierung der Variablen aus *) + INT VAR j := 1, l, scalecounter; + WHILE j <= plot param no REP + plot buf := " "; + FOR l FROM 1 UPTO 4 REP + plot buf CAT text (text (scale (j) (l)), 13) + END REP; + plot buf CAT text (scale (j) (5)); + scalecounter := plotparam (j).scalepointer; + WHILE scalecounter = plotparam (j).scalepointer REP + plot buf CAT plotparam (j).id; + j INCR 1 + UNTIL j > max param numb END REP; + plot output (plot buf) + END REP. +END PROC plot one page; + +PROC b plot scale (TEXT CONST id, INT CONST scale pointer, + REAL CONST lower bound, upper bound, + BOOL CONST l fixed scale, u fixed scale) : + (* Liest Skalierungen vom Zielprogramm ein *) + plot param no INCR 1; + plot param (plot param no).id := id; (*Variablenname *) + plot param (plot param no).scale pointer := scale pointer;(*Zeiger *) + plot param (plot param no).lower bound := lower bound; (*Obere Grenze *) + plot param (plot param no).upper bound := upper bound; (*Untere Grenze *) + plot param (plot param no).l fixed scale := l fixed scale;(*Fix-Skalierung*) + plot param (plot param no).u fixed scale := u fixed scale; +END PROC b plot scale; + +PROC gen scales : + INT VAR act param, i; (* Generiert Skalierungen fuer eine Seite *) + FOR act param FROM 1 UPTO plot param no REP + compute single scale + END REP. + + compute single scale : + REAL VAR max := plotparam(plot param(act param).scale pointer).upper bound, + min := plotparam(plot param(act param).scale pointer).lower bound; + IF min > max THEN errorstop ("invalid scale") FI; + compute extreme scales; + FOR i FROM 1 UPTO 3 REP + scale (act param) (i+1) := (scale (act param) (5) - scale (act param) (1)) + * real (i) / 4.0 + scale (act param) (1) + (* Interpolationsformel *) + END REP. + + compute extreme scales : + (* Wenn die Skalierungen nicht gegeben sind, muessen sie berechnet werden. + Zur leichteren Lesbarkeit werden die Skalierungen nach oben bzw. unten + um jeweils eine Stelle gerundet *) + scale (act param) (5) := upper limit; + scale (act param) (1) := lower limit. + + upper limit : + IF plot param (plot param (act param).scale pointer).u fixed scale + THEN max + ELSE round (floor (max) + 0.5, 0) + FI. + + lower limit : + IF plot param (plot param (act param).scale pointer).l fixed scale + THEN min + ELSE round (floor (min) - 0.5, 0) + FI. +END PROC gen scales; + +PROC b initialize plot (TEXT CONST h) : + headline := h; + pltper := get pltper; + plot line no := value pagelength; + nextplot := 0.0; + value no := nil; + line no := nil; + plot param no := nil +END PROC b initialize plot; + +PROC b new plot line (REAL CONST time) : + plt := time >= nextplot; + IF plt (* Wird vom Zielprogramm aufgerufen, um *) + THEN add (time); (* Zeilenvorschub durchzufuehren *) + line no INCR 1; + param no := nil + FI; + WHILE time >= nextplot REP (* Ist noetig, weil pltper ungleich dt sein *) + nextplot INCR pltper (* kann *) + END REP +END PROC b new plot line; + +PROC b end of program : (* Druckt am Schluss evt. noch gepufferte *) + IF plot line no = value page length AND NOT stop request (* Werte aus *) + THEN gen scales; + plot one page + FI +END PROC b end of program; + +PROC b plot (REAL CONST r) : + IF plt (* Wenn genuegend PLOT-Werte gepuffert *) + THEN get extreme value; (* sind, wird eine neue Seite gedruckt *) + add (r); + IF param no = plot param no AND line no = value pagelength + THEN gen scales; + plot one page; + value no := nil; + line no := nil + FI + FI. + + get extreme value : + (* Sucht Maximal bzw. Minimalwert, falls keine festen Skalierungs- *) + (* grenzen angegeben wurden (im Quellprogramm)*) + param no INCR 1; + INT VAR act pointer := plot param (param no).scalepointer; + set lower bound; + set upper bound. + + set lower bound : + IF NOT plot param (act pointer).l fixed scale AND + r < plot param (act pointer).lower bound + THEN plot param (act pointer).lower bound := r + FI. + + set upper bound : + IF NOT plot param (act pointer).u fixed scale AND + r > plot param (act pointer).upper bound + THEN plot param (act pointer).upper bound := r + FI. +END PROC b plot; + +PROC add (REAL CONST r) : (* Puffert PLOT-Werte *) + value no INCR 1; + value (value no) := r +END PROC add; + +END PACKET dynamo plotter; + + + + diff --git a/lang/dynamo/1.8.7/src/dyn.plot+ b/lang/dynamo/1.8.7/src/dyn.plot+ new file mode 100644 index 0000000..db04dfc --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.plot+ @@ -0,0 +1,729 @@ +PACKET graphics DEFINES graphmode, + attribut, + palette, + move, + plot, + draw line, + draw linetype, + color, + draw to: + + +(* Autor: Giffeler GD *) +(* Datum: 31.03.1988 *) +(* Schönbeck SHard *) + +INT VAR linie :: -1, farbe :: 1, dummy; + + +PROC attribut (INT CONST nr): + +(* 0..15 Vordergrundfarben fuer Textdarstellung + 0..7 Hintergrundfarben + Attribut fuer blinkende Darstellung (+128) *) + + control (-3, nr, 0, dummy) + +END PROC attribut; + + +PROC palette (INT CONST nr): + +(* Farbauswahl fuer Grafikmodi *) + + control (-4, 0, nr, dummy) + +END PROC palette; + + +PROC graphmode (INT CONST mode): + +(* 0 -> TEXT 40*25 monochrom + 2 -> 80*25 + 1 -> 40*25 farbig + 3 -> 80*25 + 7 -> 80*25 Herkules + 4 -> GRAFIK 320*200 farbig + 5 -> monochrom + 6 -> 640*200 + 64 -> Olivetti 640*400 monochrom + 72 -> kleine Schrift + 512 -> Herkules 720*348 monochrom *) + + control (-5, mode, 0, dummy) + +END PROC graphmode; + + +PROC draw linetype (INT CONST pen, color): + +(* Linienschraffur und Zeichenfarbe *) + + linie:= pen; + farbe:= color; + control (-8, linie, farbe, dummy) + +END PROC draw linetype; + + +PROC draw linetype (INT CONST nr): + +(* Ausschliessliche Aenderung der Linienschraffur *) + + linie:= nr; + control (-8, linie, farbe, dummy) + +END PROC draw linetype; + + +PROC color (INT CONST nr): + +(* Ausschliessliche Aenderung der Zeichenfarbe *) + + farbe:= nr; + control (-8, linie, farbe, dummy) + +END PROC color; + + +PROC move (INT CONST x, y): + +(* Bewegt Zeichencursor zu Koordinaten (0,0 = Links oben) *) + + control (-7, x, y, dummy) + +END PROC move; + + +PROC move (REAL CONST x, y): + + control (-7, int(x+0.5), int(y+0.5), dummy) + +END PROC move; + + +PROC draw to (INT CONST x, y): + +(* Zeichnet Gerade von momentaner Zeichencursorposition nach x,y *) + + control (-6, x, y, dummy) + +END PROC draw to; + + +PROC draw to (REAL CONST x, y): + + control (-6, int(x+0.5), int(y+0.5), dummy) + +END PROC draw to; + + +PROC draw line (INT CONST x1, y1, x2, y2): + +(* Zieht eine Linie von x1,y1 nach x2,y2 *) + + plot (x1, y1); + draw to (x2, y2) + +END PROC draw line; + + +PROC draw line (REAL CONST x1, y1, x2, y2): + + plot (x1, y1); + draw to (x2, y2) + +END PROC draw line; + + +PROC plot (INT CONST x, y): + +(* Zeichnet einen Punkt *) + + control (-7, x, y, dummy); + control (-6, x, y, dummy) + +END PROC plot; + + +PROC plot (REAL CONST x, y): + + control (-7, int(x+0.5), int(y+0.5), dummy); + control (-6, int(x+0.5), int(y+0.5), dummy) + +END PROC plot; + + +PROC draw to (INT CONST x, y, f): + +(* Zeichnet Gerade von momentaner Zeichencursorposition nach x,y *) + + color (f); + control (-6, x, y, dummy) + +END PROC draw to; + + +PROC draw to (REAL CONST x, y, INT CONST f): + + color (f); + control (-6, int(x+0.5), int(y+0.5), dummy) + +END PROC draw to; + + +PROC draw line (INT CONST x1, y1, x2, y2, f): + +(* Zieht eine Linie von x1,y1 nach x2,y2 *) + + plot (x1, y1, f); + draw to (x2, y2) + +END PROC draw line; + + +PROC draw line (REAL CONST x1, y1, x2, y2, INT CONST f): + + plot (x1, y1, f); + draw to (x2, y2) + +END PROC draw line; + + +PROC plot (INT CONST x, y, f): + +(* Zeichnet einen Punkt mit der Farbe f (0 = schwarz) *) + + color (f); + control (-7, x, y, dummy); + control (-6, x, y, dummy) + +END PROC plot; + + +PROC plot (REAL CONST x, y, INT CONST f): + + color (f); + control (-7, int(x+0.5), int(y+0.5), dummy); + control (-6, int(x+0.5), int(y+0.5), dummy) + +END PROC plot + + +END PACKET graphics; + + +PACKET dynamo plotter plus DEFINES configurate plot, + initialize plot, + new plot line, + plot, + end of program, + stop request, + plot scale: + +(* DYNAMO Grafikausgabe *) +(* Autor : Giffeler GD *) +(* Datum : 29.04.1988, 03.06.1988 *) +(* Änder.: Christian Szymanski *) +(* 21.07.88 *) + + +LET max value = 330, + value page length = 30, + max param numb = 10, + + PARAM = ROW value page length REAL, + BIG = ROW 300 REAL, + + max devices = 3, + SWITCH = STRUCT (TEXT bezeichnung, INT on, off, + zeichenbreite, zeichenhoehe, + h offset, + x, y, breite, hoehe), + SIZE = ROW max devices SWITCH; + + +TYPE PLOTPARAM = STRUCT (TEXT name, REAL lower bound, upper bound); + + +ROW max param numb PLOTPARAM VAR plotparam; +ROW max value REAL VAR value; + +BOOL VAR plt, ende; +REAL VAR pltper, nextplot; +INT VAR value no, param no, plot line no, mode nr, plot param no, line no, + xp, yp; + +SIZE CONST table :: SIZE: + (SWITCH: ("CGA 640 * 200", 6, 2, 8, 8, 5, 4, 20, 615, 102), + SWITCH: ("HGC 720 * 348", 512, 0, 0, 0, 0, 0, 0, 0, 0), + SWITCH: ("OLI 640 * 400", 64, 2, 8, 16, 10, 4, 25, 615, 223)); + +configurate plot; (* Erster Aufruf nach der Insertierung *) + + +PROC plot one page : +INT VAR loop nr, n, m; +PARAM VAR x, y; +BIG VAR xr, yr; + + kopfzeile ("Stuetzstellen: ", TRUE); + xp:= 1; yp:= 19; + FOR loop nr FROM 1 UPTO plot param no REP + werte aus value in x und y uebertragen; + koordinatenkreuz (table[mode nr].x, table[mode nr].y, + table[mode nr].breite, table[mode nr].hoehe); + x raster (table[mode nr].x, table[mode nr].y, + table[mode nr].breite, table[mode nr].hoehe, n); + zusatzinformationen ausgeben; + spline (n, m, 1, x, y, xr, yr); + draw picture (table[mode nr].x, table[mode nr].y, + table[mode nr].breite, table[mode nr].hoehe, + loop nr, m, + plot param[loop nr].lower bound, + plot param[loop nr].upper bound, + xr, yr); + legende ausgeben + PER; + abbruch; + graphmode(table[mode nr].off). + +werte aus value in x und y uebertragen: +INT CONST erh :: plot param no + 1; +INT VAR z :: 1, w :: loop nr + 1; + + FOR n FROM 1 UPTO value no DIV erh REP + x[n]:= value[z]; y[n]:= value[w]; + z INCR erh; + w INCR erh + PER; + n DECR 1; + m:= n * 10. + +zusatzinformationen ausgeben: +TEXT CONST xn :: text(x[n]); + + cursor (1, 17); put (x[1]); + cursor (81 - LENGTH xn, 17); + out (xn); + cursor (74, 1). + +legende ausgeben: +INT VAR xph, yph; + + cursor (xp, yp); + put (plot param[loop nr].name + "="); + put (plot param[loop nr].lower bound); + put ("-"); + put (plot param[loop nr].upper bound); + get cursor (xph, yph); + draw line (xph * table[mode nr].zeichenbreite - 8, + yph * table[mode nr].zeichenhoehe - table[mode nr].h offset, + xph * table[mode nr].zeichenbreite + 24, + yph * table[mode nr].zeichenhoehe - table[mode nr].h offset); + IF xp > 1 THEN line ELSE cursor (40, yph) FI; + get cursor (xp, yp). + +abbruch: +TEXT VAR eingabe; + + REP + cursor (30, 1); + put (39*" "+"(+, p, e)?"); + inchar (eingabe); + SELECT code (eingabe) OF + CASE 43 : eingabe:= "" + CASE 69, 101: ende:= TRUE; eingabe:= "" + CASE 80, 112: phasendiagramm + OTHERWISE out(""7"") + END SELECT + UNTIL eingabe = "" PER + +END PROC plot one page; + + +PROC initialize plot (TEXT CONST h) : +INT VAR c :: 1, typ; +TEXT VAR sym, num; + + ende:= FALSE; + pltper:= get pltper; + plot line no:= value page length; + nextplot:= 0.0; + value no:= 0; + line no:= 0; + plot param no:= 0; + kopfzeile zerlegen. + +kopfzeile zerlegen: + scan (h); + REP + next symbol (plot param[c].name); + next symbol (sym, typ); + IF sym = "(" THEN + next symbol (num); + next symbol (sym, typ); + IF sym = ")" THEN + plot param[c].name CAT ("(" + num + ")") + FI + FI; + WHILE typ < 7 CAND NOT (sym = "(" COR sym = ",") REP + next symbol (sym, typ) + PER; + IF typ < 7 CAND sym = "(" THEN + REP next symbol (sym) + UNTIL sym = "," PER; + REP next symbol (sym, typ) + UNTIL typ > 6 COR sym = "," COR sym = "/" PER + FI; + c INCR 1 + UNTIL typ > 6 PER + +END PROC initialize plot; + + +PROC plot scale (TEXT CONST id, INT CONST scale pointer, + REAL CONST lower bound, upper bound, + BOOL CONST l fixed scale, u fixed scale) : + + plot param no INCR 1; + plot param[plot param no].lower bound:= lower bound; + plot param[plot param no].upper bound:= upper bound + +END PROC plot scale; + + +PROC new plot line (REAL CONST time) : + + plt:= time >= nextplot; + IF plt THEN + add (time); + line no INCR 1; + param no:= 0 + FI; + WHILE time >= nextplot REP + nextplot INCR pltper + PER + +END PROC new plot line; + + +PROC plot (REAL CONST r): + + IF plt THEN + param no INCR 1; + add (r); + IF NOT ende CAND param no = plot param no AND + line no = value page length THEN + plot one page; + value no:= 0; + line no:= 0 + FI + FI + +END PROC plot; + + +PROC add (REAL CONST r): + + IF NOT ende THEN + value no INCR 1; + value[value no]:= r + FI + +END PROC add; + + +PROC spline (INT CONST n, m, s, PARAM CONST x, y, BIG VAR xr, yr): + +{ Kubische Splineinterpolation 3. Grades; 2 fach Differenzierbar } +{ Quelle: Rita Schmidt, Hahn-Meitner-Institut für Kernforschung Berlin } +{ "Spline-Prozeduren" (HMI-B 220) } +{ Umsetzung & Modifikation: Giffeler GD, 13.04.1988, 22.04.1988 } + +{ n = Anzahl der Stützstellen } +{ m = Anzahl der zu berechnenden Funktionswerte } +{ s = Index des x-Startpunktes } +{ x = x-Werte der Stützstellen (linear steigend) } +{ y = y-Werte der Stützstellen } +{ xr = x-Werte der Punkte, an denen die Funktion berechnet werden } +{ soll } +{ yr = y-Werte der Punkte, an denen die Funktion berechnet werden } +{ soll } + + +INT CONST nn :: n - 1; +REAL CONST steps :: (real(nn) * (x[2] - x[1])) / real(m - 1); + +PARAM VAR q, au; +REAL VAR hi, hk, hk1, dij, dim1j; +INT VAR k, kk, j, m1, m2, m3; + + q[1]:= 0.0; + yr[1]:= x[s]; + FOR j FROM 2 UPTO m REP yr[j]:= yr[j - 1] + steps PER; + xr:= yr; + block 0; + FOR k FROM 2 UPTO nn REP block 1 PER; + FOR kk FROM 2 UPTO nn REP block 2 PER; + FOR j FROM 1 UPTO m REP block 3 PER. + +block 0: + au[1]:= (y[3] - y[2] - y[2] + y[1]) / ((x[2] - x[1]) * (x[3] - x[2])); + au[n]:= (y[n] - y[nn] - y[nn] + y[n - 2]) / + ((x[n] - x[nn]) * (x[nn] - x[n - 2])). + +block 1: +INT CONST km1 :: k - 1, kp1 :: k + 1; + + hk:= x[k] - x[km1]; + hk1:= x[kp1] - x[k]; + q[k]:= - hk1 / (hk * (q[km1] + 2.0) + 2.0 * hk1); + au[k]:= (hk * au[km1] - 6.0 * ((y[kp1] - y[k]) / hk1 - (y[k] - + y[km1]) / hk)) * q[k] / hk1. + +block 2: + k:= nn - kk + 2; + au[k]:= q[k] * au[k + 1] + au[k]. + +block 3: + zeige benutzer das du noch lebst; + IF yr[j] < x[1] THEN + m1:= 1; + m2:= 2 + ELIF yr[j] > x[n] THEN + m1:= n - 1; + m2:= n + ELSE + m1:= 1; + m2:= n; + wiederholung + FI; + dij:= x[m2] - yr[j]; + hi:= x[m2] - x[m1]; + dim1j:= x[m1] - yr[j]; + yr[j]:= 1.0 / 6.0 / hi * (au[m1] * dij ** 3 - au[m2] * dim1j ** 3 + + (6.0 * y[m1] - hi ** 2 * au[m1]) * dij - (6.0 * y[m2] - hi ** 2 + * au[m2]) * dim1j). + +wiederholung: + REP + m3:= (m2 + m1) DIV 2; + IF yr[j] >= x[m3] THEN m1:= m3 ELSE m2:= m3 FI + UNTIL m2 - m1 = 1 PER. + +zeige benutzer das du noch lebst: + cout (j) + +END PROC spline; + + +PROC phasendiagramm: +REAL VAR l :: maxreal, u :: smallreal; +BIG VAR x, y; +INT VAR i, no1, no2; + + IF plot param no > 1 THEN + partnerwahl; + werte aus value uebertragen; + kopfzeile ("Phasendiagramm", TRUE); + koordinatenkreuz (table[mode nr].x, table[mode nr].y, + table[mode nr].breite, table[mode nr].hoehe+50); + draw picture (table[mode nr].x, table[mode nr].y, + table[mode nr].breite, table[mode nr].hoehe+50, + 1, i-1, l, u, x, y); + legende + FI. + +partnerwahl: + kopfzeile ("Phasendiagramm", FALSE); + line (2); + FOR i FROM 1 UPTO plot param no REP + putline (text(i, 3) + " = " + plot param[i].name) + PER; + REP + cursor (1, plot param no +5); + put ("X-ACHSE:"); get (no1); + cursor (1, plot param no +5); + put ("Y-ACHSE:"); get (no2) + UNTIL no1 > 0 CAND no1 <= plot param no CAND + no2 > 0 CAND no2 <= plot param no CAND + no1 <> no2 PER. + +werte aus value uebertragen: +INT CONST erh :: plot param no + 1; +INT VAR n1 :: no1 + 1, n2 :: no2 + 1; + + FOR i FROM 1 UPTO value no DIV erh REP + x[i]:= value[n1]; + y[i]:= value[n2]; + n1 INCR erh; + n2 INCR erh + PER. + +legende: + cursor (1, 23); + putline ("X-Achse: " + plot param[no1].name); + out ("Y-Achse: " + plot param[no2].name) + +END PROC phasendiagramm; + + +PROC draw picture (INT CONST x, y, xb, yb, schraffur, m, + REAL VAR lower bound, upper bound, + BIG CONST xr, yr): + +{ Ausgabe einer Funktionskurve } +{ Autor: Giffeler GD, 22.04.1988, 27.04.1988 } + +{ x = X-Position (oben links = 0) } +{ y = Y-Position (oben links = 0) } +{ xb = Ausgabebreite } +{ yb = Ausgabehöhe } +{ schraffur = Linienschraffur (1 - 10) } +{ m = Anzahl der Funktionswerte } +{ lower bound = Unterer Grenzwert (maxreal wenn Grenze beliebig) } +{ upper bound = Oberer Grenzwert (smallreal wenn Grenze beliebig) } +{ xr = Durch SPLINE erzeugte X-Werte } +{ yr = Durch SPLINE erzeugte Y-Werte } + + +ROW 10 INT CONST linienarten :: ROW 10 INT: (-1, -256, 3855, -240, + 21845, -1, -1, -1, -1, -1); + +REAL VAR lbx :: maxreal, ubx :: smallreal; +INT VAR i; + + minimum und maximum fuer x und y berechnen; + abmessungsparameter umwandeln; + spannweite errechnen; + linienschraffur bestimmen; + eine funktion ausgeben. + +minimum und maximum fuer x und y berechnen: + FOR i FROM 1 UPTO m REP + lower bound:= min (lower bound, yr[i]); + upper bound:= max (upper bound, yr[i]); + lbx:= min (lbx, xr[i]); + ubx:= max (ubx, xr[i]) + PER. + +abmessungsparameter umwandeln: +REAL CONST xpos :: real (x), ypos :: real (y), + breite :: real (xb), hoehe :: real (yb). + +spannweite errechnen: +REAL CONST sy :: (upper bound - lower bound) / hoehe, + sx :: (ubx - lbx) / breite. + +linienschraffur bestimmen: + draw linetype (linienarten [abs(schraffur) MOD 10]). + +eine funktion ausgeben: + move (xpos + (xr[1] - lbx) / sx, + ypos + hoehe - (yr[1] - lower bound) / sy); + FOR i FROM 2 UPTO m REP + drawto (xpos + (xr[i] - lbx) / sx, + ypos + hoehe - (yr[i] - lower bound) / sy) + PER + +END PROC draw picture; + + +PROC koordinatenkreuz (INT CONST nx, ny, breite, hoehe): + + anpassung; + rahmen; + pfeil oben; + pfeil rechts. + +anpassung: +INT CONST x :: nx - 1, + y :: ny - 10, + b :: breite + 21, + h :: hoehe + 11. + +rahmen: + draw linetype (-1); + draw line (x, y, x, y + h); + draw to (x + b, y + h). + +pfeil oben: + draw line (x - 3, y + 4, x, y); + draw to (x + 3, y + 4). + +pfeil rechts: + draw line (x + b - 5, y + h - 2, x + b, y + h); + draw to (x + b - 5, y + h + 2) + +END PROC koordinatenkreuz; + + +PROC x raster (INT CONST nx, ny, breite, hoehe, anzahl): +REAL CONST y :: real (ny + hoehe + 2), + w :: real (breite) / real (anzahl); +REAL VAR s :: real (nx); +INT VAR i; + + FOR i FROM 1 UPTO anzahl REP + s INCR w; + plot (s, y) + PER + +END PROC x raster; + + +PROC configurate plot: +(* +BOOL CONST cmd :: command dialogue; +INT VAR i; + + command dialogue (TRUE); + REP + bildschirmausgabe zur auswahl + UNTIL (mode nr <= max devices AND mode nr > 0) CAND + yes ("Eingabe richtig") PER; + command dialogue (cmd). + +bildschirmausgabe zur auswahl: + page; + putline ("CONFIGURATIONSTABELLE DYNAMO GRAFIK"); + line (2); + FOR i FROM 1 UPTO max devices REP + putline (text(i)+" -- "+table[i].bezeichnung) + PER; + line (2); + put ("Modus:"); + get (mode nr) + +*) +mode nr := 1. (* CGA *) +END PROC configurate plot; + + +PROC kopfzeile (TEXT CONST message, BOOL CONST grafik): + + IF grafik THEN graphmode (table[mode nr].on) + ELSE graphmode (table[mode nr].off) FI; + out (""1""); (* C.S. 21.07.88 *) + out ("DYNAMO 3.3+"); + cursor (79 - LENGTH message, 1); + out (message) + +END PROC kopfzeile; + + +PROC end of program : + + IF NOT ende CAND (value no DIV (plot param no + 1)) > 2 THEN + plot one page + FI + +END PROC end of program; + + +BOOL PROC stop request: ende END PROC stop request + + +END PACKET dynamo plotter plus + diff --git a/lang/dynamo/1.8.7/src/dyn.print b/lang/dynamo/1.8.7/src/dyn.print new file mode 100644 index 0000000..36ea279 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.print @@ -0,0 +1,43 @@ +PACKET dynamo printer DEFINES initialize print, new line, print : + +BOOL VAR prt; +TEXT VAR headline; +REAL VAR prtper, nextprint; + +PROC initialize print (TEXT CONST h) : + headline := h; + prtper := get prtper; + nextprint := 0.0 +END PROC initialize print; + +PROC new line (REAL CONST time) : + IF time >= nextprint + THEN do lf + ELSE prt := FALSE + FI; + WHILE time >= nextprint REP + nextprint INCR prtper + PER. + + do lf : + print line; + prt := TRUE; + IF pagefeed necessary OR NOT was print + THEN vdt; + sys page; + print headline + FI; + print (time). + + print headline : + println ("TIME " + headline). +END PROC new line; + +PROC print (REAL CONST r) : + IF prt + THEN print output (text (text (round (r, 5)), 13)) + FI +END PROC print + +END PACKET dynamo printer + diff --git a/lang/dynamo/1.8.7/src/dyn.proc b/lang/dynamo/1.8.7/src/dyn.proc new file mode 100644 index 0000000..a291a48 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.proc @@ -0,0 +1,160 @@ +PACKET dynamo prozeduren DEFINES clip,fifge,switch,fifze,table,tabhl, + sclprd,sum,sumv, + noise,normrn,power, + pulse,step,ramp, + set time : +(***************************************************D.Craemer 16. 2.1983 ***) +(* uses: + type TAB (Tabellen), wert, laenge + abs + random + + globale Variablen simulationtime wird durch das DYNAMO- + Programm gesetzt und in + den Funktionen, die zeit- + lich ausgeloest werden, + benutzt + + lastpulse Zeit des letzten Pulses + + +*) + +REAL VAR simulation time,last pulse:=0.0; + +PROC set time (REAL CONST time) : + simulation time := time +END PROC set time ; + +(************************ ab hier Funktionen *******************************) +(************************ zur Wertauswahl *******************************) + +REAL PROC clip(REAL CONST p,q,r,s): + IF r>=s THEN p ELSE q FI + END PROC clip; + +REAL PROC fifge(REAL CONST p,q,r,s): + clip(p,q,r,s) + END PROC fifge; + +(* clip und fifge machen dasselbe, der Name fifge gibt die Funktion besser +wieder: first if greater or equal + = == = = *) + +REAL PROC switch (REAL CONST p,q,r): + IF r=0.0 THEN p ELSE q FI + END PROC switch; + +REAL PROC fifze (REAL CONST p,q,r): + switch(p,q,r) + END PROC fifze; + +(* Funktion switch oder fifze: first if zero + = == == *) + +(************************ ab hier Funktionen *******************************) +(************************ mit Tabellen *******************************) + +REAL PROC table (TAB CONST t, REAL CONST x, xlow, x high, xincr) : + IF x < x low OR x > x high + THEN putline("TABLE out of range: xlow="+text(xlow)+" x="+text(x)+ + " xhigh="+text(xhigh)+" xincr="+text(xincr));0.0 + ELIF x=xhigh + THEN wert(t,laenge(t)) + ELIF x=xlow + THEN wert(t,1) + ELSE deliver interpolated value + FI. + +deliver interpolated value: + INT VAR index :: int((x-xlow)/xincr)+1; + REAL VAR m :: ((wert (t, index + 1) - wert (t, index)) / x incr), + b :: wert (t, index); + + m * (x-(xlow+real(index-1)*xincr)) + b. +END PROC table; + + +REAL PROC tabhl (TAB CONST t, REAL CONST x, xlow, x high, xincr) : + IF xlow < x AND x < xhigh + THEN table(t,x,xlow,xhigh,xincr) + ELIF x <= xlow + THEN wert(t,1) + ELSE wert(t,laenge(t)) + FI +END PROC tabhl ; + +REAL PROC sclprd(TAB CONST tab1,REAL CONST erstes1,letztes1,TAB CONST tab2, + REAL CONST erstes2): +INT VAR i; +REAL VAR summe:=0.0; +FOR i FROM 0 UPTO int(letztes1-erstes1) REP + summe:=summe + wert(tab1,int(erstes1)+i)*wert(tab2,int(erstes2)+i) +PER; +summe +END PROC sclprd; + +REAL PROC sumv(TAB CONST tab, REAL CONST erstes,letztes): +REAL VAR summe:=0.0; +INT VAR i; +FOR i FROM int(erstes) UPTO int(letztes) REP + summe:=summe+wert(tab,i) +PER; +summe +END PROC sumv; + +REAL PROC sum(TAB CONST tab): + sumv(tab,1.0,real(laenge(tab))) +END PROC sum; + +(************************ ab hier Funktionen *******************************) +(************************ mit Zufallszahlen *******************************) + +REAL PROC noise(REAL CONST dummy): + random-0.5 +END PROC noise; + +REAL PROC normrn(REAL CONST mittelwert,stdvar): +REAL VAR z:=0.0; +INT VAR i; +(* Methode nach NAYLOR et al.: Computer Simulation Technique, Wiley,NY 1966*) +FOR i FROM 1 UPTO 12 REP + z:=z+random +PER; +z:=z-6.0; +mittelwert+z*stdvar +END PROC normrn; + +(************************ ab hier Funktionen *******************************) +(************************ mit Zeitausloesung ******************************) + +REAL PROC pulse(REAL CONST height,first,interval): +IF simulationtime < first THEN lastpulse:=0.0; 0.0 + ELIF abs(simulationtime-first) < smallreal THEN lastpulse:=simulationtime; + height + ELIF abs(simulationtime-(lastpulse+interval)) < smallreal THEN + lastpulse:=simulationtime; + height + ELSE 0.0 +END IF +END PROC pulse; + +REAL PROC step(REAL CONST height,steptime): + IF simulationtime<steptime THEN 0.0 + ELSE height + FI +END PROC step; + +REAL PROC ramp(REAL CONST slope,start): + IF simulationtime<start THEN 0.0 + ELSE slope*(simulationtime-start) + FI +END PROC ramp; + +REAL PROC power(REAL CONST basis,exponent): + basis**int(exponent) +END PROC power + + +END PACKET dynamo prozeduren + diff --git a/lang/dynamo/1.8.7/src/dyn.quadrat b/lang/dynamo/1.8.7/src/dyn.quadrat new file mode 100644 index 0000000..fdd553a --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.quadrat @@ -0,0 +1,13 @@ +NOTE HIER BERECHNEN WIR DAS QUADRAT MITTELS ABLEITUNG ! +L F.K=F.J+2*TIME.J*DT +N F=0 +C DT=0.01 +NOTE DT WIRD EXTRA SO KLEIN GEWAEHLT; DAMIT DIE ANNAEHERUNG GUT IST +NOTE +NOTE DAS GEHT AUF KOSTEN DER RECHENZEITEN !!! +C LENGTH=17 +C PLTPER=1 +PLOT F +C PRTPER=1 +PRINT F + diff --git a/lang/dynamo/1.8.7/src/dyn.rts b/lang/dynamo/1.8.7/src/dyn.rts new file mode 100644 index 0000000..c46684a --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.rts @@ -0,0 +1,376 @@ +PACKET rts + DEFINES constant, vdt, get pltper, get prtper, was print, + println, print output, plot output, print line, + sys page, pagefeed necessary, print suppressed output, asterisk, + protokoll, default, set pagelength, run time system, b stop request, + scroll, run card : + (* Runtime - System *) + (* Autor : R. Keil *) + (* Datum : 12.07.83 Aenderung: 19.06.84 D. Craemer *) + (* 2.Aenderung: 6.05.85 D. Craemer *) + (* Änderung auf 1.8.2: Z. 288, Christian Szymanski, 10.08.88 *) + (* In der 2. Aenderung wurde dyn.const in zzdyn.const umbenannt*) + (* und alle Konstanten-Datenraeume bekommen ".const" angehaengt*) + (* Wird im rts das Kommando run name gegeben, so wird der *) + (* augenblickliche Konstanten-Datenraum gerettet im Datenraum *) + (* mit dem Namen: "name.const" *) + + + + LET esc = ""27"", + max tab size = 50, + bold = 1, + number = 2, + delimiter = 3; + +TYPE CONSTANT = STRUCT (ROW max tab size TEXT name, + ROW max tab size REAL value, + INT tab size); + +BOUND CONSTANT VAR constants; + +FILE VAR sysout; +TEXT VAR print buf, asterisk buffer, sym, const name, + const space name::"zzdyn.const"; +REAL VAR dt, length, prtper, pltper; +INT VAR line no, page no, max pagelength, type; + +BOOL VAR vdt on, print, protocoll, terminal stop, is scroll, + is not first, run specified; + + +default; + +PROC default : + protocoll := FALSE; + max pagelength := 23; + is scroll := TRUE; + run specified := FALSE +END PROC default; + +PROC set pagelength (INT CONST i) : + max pagelength := i +END PROC set pagelength; + +PROC run card (TEXT CONST run name) : + IF exists (actual constants) + THEN constants := old (actual constants) + ELIF run name="zzdyn" + THEN constants := new (actual constants); + CONCR (constants).tab size := 0 + ELSE copy (const space name, actual constants); + constants := old (actual constants) + FI; + const space name := actual constants. + + actual constants: + run name + ".const". + +END PROC run card; + +REAL PROC constant (TEXT CONST name, REAL CONST val) : + REAL VAR value; + INT VAR tab pos; + value := actual value; + set system consts. + + actual value : + search constant (name, tab pos); + IF tab pos > 0 + THEN CONCR (constants).value (tab pos) + ELSE new constant (name, val); + val + FI. + + set system consts : + SELECT pos ("dt length prtper pltper ", name + " ") OF + CASE 1 : dt := value + CASE 4 : length := value + CASE 11 : prtper := value + CASE 18 : pltper := value + END SELECT; + value. +END PROC constant; + +PROC new constant (TEXT CONST name, REAL CONST val) : + CONCR (constants).tab size INCR 1; + IF CONCR (constants).tab size > max tab size + THEN errorstop ("ZUVIELE KONSTANTEN") + FI; + CONCR (constants).name (CONCR (constants).tab size) := name; + CONCR (constants).value (CONCR (constants).tab size) := val +END PROC new constant; + +PROC search constant (TEXT CONST name, INT VAR tab pos) : + INT VAR i; + FOR i FROM 1 UPTO CONCR (constants).tab size REP + IF name = CONCR (constants).name (i) + THEN tab pos := i; + LEAVE search constant + FI + END REP; + tab pos := 0 +END PROC search constant; + +REAL PROC get pltper : (* Reicht 'pltper' (Plotperiode) heraus *) + pltper +END PROC get pltper; + +REAL PROC get prtper : (* Reicht 'prtper' (Printperiode) heraus *) + prtper +END PROC get prtper; + +PROC scroll (BOOL CONST b) : + is scroll := b +END PROC scroll; + +PROC next sym : + next sym (sym, type) +END PROC next sym; + +PROC rts err (TEXT CONST err mess) : + outline ("FEHLER BEI >>>" + sym + "<<< : " + err mess) +END PROC rts err; + +PROC run time system (PROC target program) : + IF protocoll + THEN kill ("dyn.out"); + sysout := sequential file (output, "dyn.out") + FI; + init rts; + REP + get command; + execute command + END REP. + + get command : + TEXT VAR command; + print suppressed output; + line; + putline (" dynamo runtime system :"); + shift; + getline (command); + printline (command). + + execute command : + scanner (command); + next sym; + TEXT VAR start := sym; + skip blanks; + SELECT pos ("run rerun quit help c ? EOL ", start + " ") OF + CASE 1, 5 : run + CASE 11 : quit + CASE 16 : show ("dyn.help") + CASE 21 : const equ + CASE 23 : dump consts + CASE 25 : + OTHERWISE : rts err ("KOMMANDO UNBEKANNT") + END SELECT. + + run : + init rts; + IF type = bold OR type = delimiter + THEN run card (sym) + FI; + target program. + + quit : + IF const space name = "zzdyn.const" + THEN kill (const space name) + FI; + LEAVE runtime system. + + skip blanks : + REP + next sym + UNTIL sym <> " " END REP. + + const equ : + REAL VAR value, dummy; + INT VAR tab pos; + REP + analyze constant equ; + search constant (const name, tab pos); + IF tab pos = 0 + THEN sym := const name; + rts err ("KONSTANTE NICHT DEFINIERT") + ELSE CONCR (constants).value (tab pos) := value + FI + UNTIL end of constants END REP. + + analyze constant equ : + IF type <> bold + THEN rts err ("NAME ERWARTET") + FI; + const name := sym; + next sym; + IF sym <> "=" + THEN rts err ("^=^ ERWARTET") + FI; + get constant. + + end of constants : + next sym; + IF sym = "/" OR sym = "," + THEN next sym; FALSE + ELSE TRUE + FI. + + get constant : + next sym; + value := 1.0; + IF sym = "-" + THEN value := -1.0; next sym + ELIF sym = "+" + THEN next sym + FI; + IF type = number + THEN value := value * real (sym) + ELSE rts err ("ZAHL ERWARTET") + FI. + + dump consts : + INT VAR i; + FOR i FROM 1 UPTO CONCR (constants).tab size REP + IF (i MOD 2) = 1 + THEN line; shift + FI; + out (text (CONCR (constants).name (i), 14), " = ", + text (text (CONCR (constants).value (i)), 13)) + END REP; + line. +END PROC run time system; + +PROC shift : + out (" ") +END PROC shift; + +PROC init rts : + line no := 0; + page no := 0; + asterisk buffer := ""; + print buf := ""; + print := FALSE; + terminal stop := FALSE; + is not first := FALSE; + vdt on := TRUE +END PROC init rts; + +PROC protokoll (BOOL CONST b) : + protocoll := b +END PROC protokoll; + +PROC print line : + BOOL VAR b := print; (* Druckt Ausgabe - Puffer und *) + println (print buf); (* loescht anschliessend den Inhalt *) + print buf := ""; + print := b +END PROC print line; + +PROC print suppressed output : + IF print buf <> "" (* Druckt Ausgabe - Puffer, *) + THEN println (print buf); (* falls gefuellt *) + print buf := "" + FI +END PROC print suppressed output; + +PROC print output (TEXT CONST t) : + print buf CAT t; (* Fuellt Ausgabe - Puffer *) + print buf CAT " " +END PROC print output; + +PROC println (TEXT CONST t) : + print := TRUE; (* Verteilt Ausgabe auf Bildschirm *) + line no INCR 1; (* und Datei *) + outline (t); + IF line no = max page length + THEN line no := 0 + FI; + IF is getcharety (esc) (* bis einschl. 1.8.1: 'is incharety' *) + THEN terminal stop := TRUE + FI. +END PROC println; + +PROC outline (TEXT CONST t) : + printline (t); + putline (actual line). + + actual line : + IF LENGTH (t) > 78 + THEN text (t, 78) + ELSE t + FI. +END PROC outline; + +PROC printline (TEXT CONST t) : + IF protocoll + THEN putline (sysout, t) + FI +END PROC print line; + +PROC sys page : (* Seitenvorschub auf Bildschirm und Datei *) + IF vdt on AND NOT is scroll AND is not first + THEN page + ELSE is not first := TRUE + FI; + IF protocoll + THEN putline (sysout, "#page#") + FI; + IF asterisk buffer <> "" + THEN page no INCR 1; + println ("PAGE " + text (page no, 3) + " : " + asterisk buffer); + FI; + line no := 0 +END PROC sys page; + +BOOL PROC pagefeed necessary : + line no = 0 (* Liefert TRUE, wenn Seitenende erreicht *) +END PROC pagefeed necessary; (* ist *) + +PROC plot output (TEXT CONST t) : + println (t); (* Ausgabeprozedur fuer das Plot - Programm *) + print := FALSE +END PROC plot output; + +BOOL PROC b stop request : (* Liefert TRUE, wenn 'End'-Kommando im VDT *) + terminal stop (* - Modus gegeben wird *) +END PROC b stop request; + +BOOL PROC was print : (* Liefert TRUE, falls Druckerprogramm *) + print. (* vorher eine Zeile gedruckt hat *) +END PROC was print; + +PROC vdt : + IF vdt on AND is not first (* VDT = Video Data Termination *) + THEN do vdt (* Verhindert Scrolling des Bildschirms *) + FI. + + do vdt : + TEXT VAR t; + out ("TIPPEN SIE : '+'; 'o'; 'e' : "); + inchar (t); + out (t); + IF t = "+" (* '+' = Seitenvorschub *) + THEN + ELIF t = "o" (* 'o' = Off; VDT wird abgeschaltet *) + THEN vdt on := FALSE + ELIF t = "e" (* 'e' = End; Programm wird abgebrochen *) + THEN terminal stop := TRUE + ELSE out (""13""); vdt + FI; + line. +END PROC vdt; + +PROC asterisk (TEXT CONST t) : + asterisk buffer := t +END PROC asterisk; + +PROC out(TEXT CONST a,b,c) : + out(a); + out(b); + out(c) +END PROC out; + + +END PACKET rts; + diff --git a/lang/dynamo/1.8.7/src/dyn.ruestungswettlauf b/lang/dynamo/1.8.7/src/dyn.ruestungswettlauf new file mode 100644 index 0000000..7b7c6b1 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.ruestungswettlauf @@ -0,0 +1,32 @@ +note ruestungswettlauf nach richardson +note +note literatur: thiel "quantitaet oder begriff" S. 436 ff +note +l eigenkriegspot.k=eigenkriegspot.j+dt* +x (k*gegenkriegspot.j-a*eigenkriegspot.j+g) +l gegenkriegspot.k=gegenkriegspot.j+dt* +x (l*eigenkriegspot.j-b*gegenkriegspot.j+h) +note +note anfangswerte fuer eigenkriegspotential und gegenkriegspotential +note werden am gleichgewichtspunkt plus etwas mehrpot gegeben +note +n eigenkriegspot=(k*h+b*g)/(a*b-k*l)+mehrpot +n gegenkriegspot=(l*g+a*h)/(a*b-k*l) +note +note konstanten +note +c k=2 verteidigungskoeffizient +c l=1 " des gegners +c a=2 koeffizient fuer aufwand zur kriegsvorbereitung +c b=3 " +c g=7 koeffizient fuer aggressive absichten +c h=9 " +c mehrpot=3 stoerung des gleichgewichts durch mehr potential +plot eigenkriegspot=e,gegenkriegspot=g(unten,oben) +c dt=0.5 +c length=2050 +n time=1985 +c pltper=1 +c unten=-11 +c oben=250 + diff --git a/lang/dynamo/1.8.7/src/dyn.simon b/lang/dynamo/1.8.7/src/dyn.simon new file mode 100644 index 0000000..b911159 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.simon @@ -0,0 +1,28 @@ +NOTE Simons MODELL der sozialen Gruppe Stand: 08.03.1983 +NOTE +A INTERAKT.K=A1*FREUNDLICH.K+A2*AKTIV.K +L FREUNDLICH.K=FREUNDLICH.J+DT*(B1*(INTERAKT.J-beta*FREUNDLICH.J)) +L AKTIV.K=AKTIV.J+DT*(C1*(FREUNDLICH.J-gamma*AKTIV.J)+C2*(EINF-AKTIV.J)) +N INTERAKT=beta*A2*C2*EINF/NENNER +N AKTIV=C2*(beta-A1)*EINF/NENNER +N FREUNDLICH=A2*C2*EINF/NENNER+STOERTERM +N NENNER=-C1*A2+(beta-A1)*(C2+C1*gamma) +C STOERTERM=0.4 +C EINF=2 +NOTE +NOTE Konstanten sind alle positiv vorausgesetzt +NOTE Stabil fuer beta>a1 +C A1=1.0 +C A2=1.5 +C B1=1 +C beta=1.0 +C C1=1.4 +C C2=1.5 +C gamma=1.5 +C DT=0.1 +C LENGTH=60 +C PLTPER=0.5 +PLOT INTERAKT=i,FREUNDLICH=f,AKTIV=a(-10,10) +PRINT INTERAKT,FREUNDLICH,AKTIV +C PRTPER=0.5 + diff --git a/lang/dynamo/1.8.7/src/dyn.std b/lang/dynamo/1.8.7/src/dyn.std new file mode 100644 index 0000000..a87b66d --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.std @@ -0,0 +1,9 @@ +abs r arctan r arctand r cos r cosd r exp r floor r frac r +initializerandom r random r +ln r log2 r log10 r +max rr min rr +power rr round r +sin r sind r sqrt r tan r tand r +clip rrrr fifge rrrr switch rrr fifze rrr noise r normrn rr pulse rrr +ramp rr sclprd trrtr step rr sumv trr sum t table trrrr tabhl trrrr /* + diff --git a/lang/dynamo/1.8.7/src/dyn.steifedgl b/lang/dynamo/1.8.7/src/dyn.steifedgl new file mode 100644 index 0000000..b168fcd --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.steifedgl @@ -0,0 +1,15 @@ +NOTE STIFF EQUATIONS SIEHE: SIMULATION AUGUST 1980, SEITE 38 +L Y1.K=Y1.J+DT*(-21*Y1.J+19*Y2.J-20*Y3.J) +L Y2.K=Y2.J+DT*(+19*Y1.J-21*Y2.J+20*Y3.J) +L Y3.K=Y3.J+DT*(+40*Y1.J-40*Y2.J-40*Y3.J) +N Y1=1 +N Y2=0 +N Y3=-1 +NOTE KONSTANTEN MUESSEN GEEIGNET GEWAEHLT WERDEN: DT SEHR KLEIN +C LENGTH=20 +C DT=.01 +C PRTPER=1 +C PLTPER=1 +PRINT Y1,Y2,Y3 +PLOT Y1,Y2,Y3 + diff --git a/lang/dynamo/1.8.7/src/dyn.tool b/lang/dynamo/1.8.7/src/dyn.tool new file mode 100644 index 0000000..65769d8 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.tool @@ -0,0 +1,217 @@ +PACKET io handling DEFINES error listing, err, message, errors, init errors, + text, kill, trunc, hash, no errors : +(* Autor : R. Keil, Version vom 22.07.83, Änderung: C. Szymanski, 21.07.88 *) + +LET errmax = 67, + max hash size = 300; + +ROW errmax TEXT VAR error; +FILE VAR listfile; (* -> VERSION 3.2 *) +BOOL VAR list; +INT VAR errorno, i; + +PROC init errors (TEXT CONST fname) : + FILE VAR errorfile := sequential file (input, fname); + TEXT VAR buffer; + FOR i FROM 1 UPTO errmax WHILE NOT eof (errorfile) REP + getline (errorfile, buffer); + error (i) := buffer + END REP +END PROC init errors; + +PROC init errors : + errorno := 0 +END PROC init errors; + +PROC error listing (TEXT CONST listname) : + list := listname <> "nolist"; + IF list + THEN kill (listname); + listfile := sequential file (output, listname) + FI +END PROC error listing; + +INT PROC errors : + error no +END PROC errors; + +PROC err (TEXT CONST s, INT CONST m, line no) : + message ("Fehler in Zeile " + text (line no) + " bei >>" + s + "<< : " + + error (m)); + errorno INCR 1 +END PROC err; + +BOOL PROC no errors : + IF errors = 0 + THEN TRUE + ELSE display (text (error no) + " Fehler gefunden"13""10""); FALSE + FI +END PROC no errors; + +PROC message (TEXT CONST m) : + IF list + THEN putline (list file, m); + FI; + note (m); (* C.S. 21.07.88 *) + note line; + display (m); + display (""13""10"") +END PROC message; + +TEXT PROC text (BOOL CONST b) : + IF b + THEN "TRUE" + ELSE "FALSE" + FI +END PROC text; + +PROC kill (TEXT CONST file name) : + command dialogue (FALSE); + forget (file name); + command dialogue (TRUE) +END PROC kill; + +TEXT PROC trunc (TEXT CONST t) : + text (t, length (t) - 2) +END PROC trunc; + +INT PROC hash (TEXT CONST word) : + INT VAR qs := 0; + FOR i FROM 1 UPTO length (word) REP + qs INCR code (word SUB i) + END REP; + (qs MOD max hash size) + 1. +END PROC hash + +END PACKET io handling; + + +(************************* S C A N N E R **************************) + +PACKET scan DEFINES next sym, scanner, scanpos : + + +LET bold = 1, (* Autor : R. Keil, T. Froehlich *) + number = 2, (* Version vom 04.07.83 *) + delimiter = 3, + eol = 4; + +TEXT VAR main buf, sym; +INT VAR position, type, cc, begin pos; + +PROC nextsym (TEXT CONST buf, TEXT VAR scan sym, + INT VAR scan type, pos) : + TEXT VAR char := buf SUB pos; + cc := code (char); + IF (cc >= 97 AND cc <= 122) + THEN process lower case + ELIF cc = 46 OR is int + THEN process real + ELIF (cc >= 65 AND cc <= 90) + THEN process upper case + ELSE process delimiter + FI. + + process upper case : + scan type := bold; + scan sym := low; + next char; + WHILE (cc >= 65 AND cc <= 90) OR is int REP + scan sym CAT low; + next char + END REP. + + process lower case : + scan type := bold; + begin pos := pos; + REP + next char + UNTIL lower case char AND NOT is int END REP; + scan sym := subtext (buf, begin pos, pos - 1). + + lower case char : + cc < 97 OR cc > 122. + + process real : + process base; + process exponent; + scan type := number. + + process base : + IF cc = 46 + THEN next char; + IF is int + THEN scan sym := "0."; + process int + ELSE scan type := delimiter; + scan sym := "."; + LEAVE process real + FI + ELSE scan sym := ""; + process int; + IF cc = 46 + THEN scan sym CAT char; + next char; + IF is int + THEN process int + ELSE scan sym CAT "0" + FI + ELSE scan sym CAT ".0" + FI + FI. + + process exponent : + IF cc = 69 OR cc = 101 + THEN scan sym CAT "e"; + next char; + IF cc = 43 OR cc = 45 + THEN scan sym CAT char; next char + FI; + IF is int + THEN process int + ELSE err (char, 63, 0) + FI + FI. + + process int : + WHILE is int REP + scan sym CAT char; + next char + END REP. + +is int : + cc >= 48 AND cc <= 57. + + process delimiter : + IF cc = -1 + THEN scan sym := "EOL"; scan type := eol + ELSE scan type := delimiter; + scan sym := char + FI; + pos INCR 1. + + next char : + pos INCR 1; char := buf SUB pos; cc := code (char). + + low : + IF cc >= 65 AND cc <= 90 + THEN code (cc + 32) + ELSE char + FI. +END PROC next sym; + +PROC scanner (TEXT CONST buf) : + main buf := buf; position := 1 +END PROC scanner; + +PROC next sym (TEXT VAR sym, INT VAR type) : + next sym (main buf, sym, type, position) +END PROC next sym; + +INT PROC scanpos : + position +END PROC scanpos + +END PACKET scan + + diff --git a/lang/dynamo/1.8.7/src/dyn.vec b/lang/dynamo/1.8.7/src/dyn.vec new file mode 100644 index 0000000..0554215 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.vec @@ -0,0 +1,209 @@ +PACKET vector DEFINES TAB, :=, vector, (* Autor : H.Indenbirken *) + SUB, LENGTH, laenge, norm, (* Stand : 24.09.81 *) + nilvector, replace, =, <>, wert, + +, -, *, /, + get, put : + +LET n = 4000; + +TYPE TAB = STRUCT (INT lng, TEXT elem); +TYPE INITTAB = STRUCT (INT lng, REAL value); + +INT VAR i; +TEXT VAR t :: "12345678"; +TAB VAR v :: nilvector; + + +REAL PROC wert (TAB CONST t, INT CONST i) : + t SUB i +END PROC wert; + +OP := (TAB VAR l, TAB CONST r) : + l.lng := r.lng; + l.elem := r.elem + +END OP :=; + +OP := (TAB VAR l, INITTAB CONST r) : + l.lng := r.lng; + replace (t, 1, r.value); + l.elem := r.lng * t + +END OP :=; + +INITTAB PROC nilvector : + vector (1, 0.0) + +END PROC nilvector; + +INITTAB PROC vector (INT CONST lng, REAL CONST value) : + IF lng <= 0 + THEN errorstop ("PROC vector : lng <= 0") FI; + INITTAB : (lng, value) + +END PROC vector; + +INITTAB PROC vector (INT CONST lng) : + vector (lng, 0.0) + +END PROC vector; + +REAL OP SUB (TAB CONST v, INT CONST i) : + test ("REAL OP SUB : ", v, i); + v.elem RSUB i + +END OP SUB; + +INT OP LENGTH (TAB CONST v) : + v.lng + +END OP LENGTH; + +INT PROC laenge (TAB CONST v) : + v.lng + +END PROC laenge; + +REAL PROC norm (TAB CONST v) : + REAL VAR result :: 0.0; + FOR i FROM 1 UPTO v.lng + REP result INCR ((v.elem RSUB i)**2) PER; + sqrt (result) . + +END PROC norm; + +PROC replace (TAB VAR v, INT CONST i, REAL CONST r) : + test ("PROC replace : ", v, i); + replace (v.elem, i, r) + +END PROC replace; + +BOOL OP = (TAB CONST l, r) : + l.elem = r.elem +END OP =; + +BOOL OP <> (TAB CONST l, r) : + l.elem <> r.elem +END OP <>; + +TAB OP + (TAB CONST v) : + v +END OP +; + +TAB OP + (TAB CONST l, r) : + test ("TAB OP + : ", l, r); + v := l; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (l.elem RSUB i) + (r.elem RSUB i)) PER; + v + +END OP +; + +TAB OP - (TAB CONST a) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, - (a.elem RSUB i)) PER; + v + +END OP -; + +TAB OP - (TAB CONST l, r) : + test ("TAB OP - : ", l, r); + v := l; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (l.elem RSUB i) - (r.elem RSUB i)) PER; + v +END OP -; + +REAL OP * (TAB CONST l, r) : + test ("REAL OP * : ", l, r); + REAL VAR x :: 0.0; + FOR i FROM 1 UPTO l.lng + REP x INCR ((l.elem RSUB i) * (r.elem RSUB i)) PER; + x + +END OP *; + +TAB OP * (TAB CONST v, REAL CONST r) : + r*v + +END OP *; + +TAB OP * (REAL CONST r, TAB CONST a) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, r*(a.elem RSUB i)) PER; + v + +END OP *; + +TAB OP / (TAB CONST a, REAL CONST r) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (a.elem RSUB i)/r) PER; + v + +END OP /; + +TEXT VAR error :: ""; +PROC test (TEXT CONST proc, TAB CONST v, INT CONST i) : + IF i > v.lng + THEN error := proc; + error CAT "subscript overflow (LENGTH v="; + error CAT text (v.lng); + error CAT ", i="; + error CAT text (i); + error CAT ")"; + errorstop (error) + ELIF i < 1 + THEN error := proc; + error CAT "subscript underflow (i = "; + error CAT text (i); + error CAT ")"; + errorstop (error) + FI . + +END PROC test; + +PROC test (TEXT CONST proc, TAB CONST a, b) : + IF a.lng <> b.lng + THEN error := proc; + error CAT "LENGTH a ("; + IF a.lng <= 0 + THEN error CAT "undefined" + ELSE error CAT text (a.lng) FI; + error CAT ") <> LENGTH b ("; + error CAT text (b.lng); + error CAT ")"; + errorstop (error) + FI + +END PROC test; + +PROC get (TAB VAR v, INT CONST lng) : + v.lng := lng; + v.elem := lng * "12345678"; + REAL VAR x; + FOR i FROM 1 UPTO lng + REP get (x); + replace (v.elem, i, x) + PER . + +END PROC get; + +PROC put (TAB CONST v, INT CONST laenge, fracs) : + FOR i FROM 1 UPTO v.lng + REP put (text (v.elem RSUB i, laenge, fracs)) PER + +END PROC put; + +PROC put (TAB CONST v) : + FOR i FROM 1 UPTO v.lng + REP put (text (v.elem RSUB i)) PER + +END PROC put; + +END PACKET vector; + + + diff --git a/lang/dynamo/1.8.7/src/dyn.wachstum b/lang/dynamo/1.8.7/src/dyn.wachstum new file mode 100644 index 0000000..9f97bb9 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.wachstum @@ -0,0 +1,19 @@ +NOTE +NOTE Ein einfaches Modell des Bevoelkerungswachstums +NOTE +L BEVOELKERUNG.K=BEVOELKERUNG.J+DT*GEBURTENRATE.JK +N BEVOELKERUNG=ANFANGSBEVOELKERUNG +C ANFANGSBEVOELKERUNG=1000 +R GEBURTENRATE.KL=BEVOELKERUNG.K*WACHSTUMSFAKTOR +N GEBURTENRATE=10 +C WACHSTUMSFAKTOR=0.03 das heisst: 3 Prozent +NOTE +NOTE Simulationsparameter +NOTE +PLOT BEVOELKERUNG=B(1E3,9E4)/GEBURTENRATE=G(10,9E3) +C DT=1 +C PLTPER=5 +C LENGTH=300 + + + diff --git a/lang/dynamo/1.8.7/src/dyn.wasseröko b/lang/dynamo/1.8.7/src/dyn.wasseröko new file mode 100644 index 0000000..fe05881 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.wasseröko @@ -0,0 +1,64 @@ +n t=15 +note*** wasserökosystem nach abel und reich +note*** in: microextra 4/83 seite 34 ff +note************************************************************************ +note* hilfsgleichung fuer temperatur t +note* die zeit time in wochen + +a t.k=15+4*sin((time.k-10)*2*pi/52) temperatur t; time in wochen +c pi=3.1415 +note gleichung fuer phytoplankton p + +l p.k=p.j+dt*(p.j*(p1*n.j*t.j-p2*z.j)(100-p.j)/100) phytoplankton p +note gleichung fuer zooplankton z + +l z.k=z.j+dt*(z.j*(p3*t.j*p.j+p4*n.j-(p5*f.j+p6*b.j)-1/p.j)(30-z.j)/30) +note gleichung fuer fische f +l f.k=f.j+dt*(f.j*(p7*z.j-p8*b.j-p9/(z.j+p.j))(10-f.j)/10) + +note gleichung fuer raubfisch barsch b + +l b.k=b.j+dt*(b.j*(p10*f.j+p11*z.j-1/(p12*f.j))(0.1-b.j)/0.1) + +note **** gleichung fuer naehrstoffmenge n + +l n.k=n.j+dt*(p13-n.j*(p14*p.j-p15*z.j)) +note **** anfangswerte **************************************************** +n p=p0 +n z=z0 +n f=f0 +n b=b0 +n n=n0 +c p0=10 +c z0=3 +c f0=1 +c b0=0.01 +c n0=30 in kg/volumeneinheit bzw. Stück/volumeneinhe�[ +note ***** konstanten ******************************************************** +c p1=0.006 +c p2=1 +c p3=0.006 +c p4=0.03 +c p5=1 +c p6=100 +c p7=0.33 +c p8=100 +c p9=1E-4 +c p10=1 +c p11=1 +c p12=0.25 +c p13=10 +c p14=0.1 +c p15=0.2 +note **** simulationskonstanten ********************************************* +c dt=0.5 +c length=60 +c pltper=1 +note***** outputvariablen**************************************************** +a lp.k=ln(p.k/p0) +a lz.k=ln(z.k/z0) +a lf.k=ln(f.k/f0) +a lb.k=ln(b.k/b0) +a logn.k=ln(n.k/n0) +plot lp=p,lz=z,lf=f,lb=b,logn=n(-4,4) + diff --git a/lang/dynamo/1.8.7/src/dyn.welt-forrester b/lang/dynamo/1.8.7/src/dyn.welt-forrester new file mode 100644 index 0000000..c3f9789 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.welt-forrester @@ -0,0 +1,124 @@ +note weltmodell in der form fuer eumel dynamo 17.7.1987 +* WORLD DYNAMICS W5 +L p.k=p.j+(dt)*(br.jk-dr.jk) +N p=pi +C pi=1.65e9 +R br.kl=(p.k)*(clip(brn,brn1,swt1,time.k))*(brfm.k)*(brmm.k) +X *(brcm.k)*(brpm.k) +C brn=.04 +C brn1=.04 +C swt1=1970 +A brmm.k=tabhl(brmmt,msl.k,0,5,1) +T brmmt=1.2/1/.85/.75/.77/.7 +A msl.k=ecir.k/(ecirn) +C ecirn=1 +A ecir.k=(cir.k)*(1-ciaf.k)*(nrem.k)/(1-ciafn) +A nrem.k=table(nremt,nrfr.k,0,1,.25) +T nremt=0/.15/.5/.85/1 +A nrfr.k=nr.k/nri +L nr.k=nr.j+(dt)*(-nrur.jk) +N nr=nri +C nri=900e9 +R nrur.kl=(p.k)*(clip(nrun,nrun1,swt2,time.k))*(nrmm.k) +C nrun=1 +C nrun1=1 +C swt2=1970 +NOTE equation 42 connects here from eq. 4 to eq.9 +R dr.kl=(p.k)*(clip(drn,drn1,swt3,time.k))*(drmm.k)*(drpm.k) +X *(drfm.k)*(drcm.k) +C drn=.028 +C drn1=.028 +C swt3=1970 +A drmm.k=tabhl(drmmt,msl.k,0,5,.5) +T drmmt=3/1.8/.8/.7/.6/.53/.5/.5/.5/.5 +A drpm.k=table(drpmt,polr.k,0,60,10) +T drpmt=.92/1.3/2/3.2/4.8/6.8/9.2 +A drfm.k=tabhl(drfmt,fr.k,0,2,.25) +T drfmt=30/3/2/1.4/1/.7/.6/.5/.5 +A drcm.k=table(drcmt,cr.k,0,5,1) +T drcmt=.9/1/1.2/1.5/1.9/3 +A cr.k=(p.k)/(la*pdn) +C la=135e6 +C pdn=26.5 +A brcm.k=table(brcmt,cr.k,0,5,1) +T brcmt=1.05/1/.9/.7/.6/.55 < +A brfm.k=tabhl(brfmt,fr.k,0,4,1) +T brfmt=0/1/1.6/1.9/2 +A brpm.k=table(brpmt,polr.k,0,60,10) +T brpmt=1.02/.9/.7/.4/.25/.15/.1 +A fr.k=(fpci.k)*(fcm.k)*(fpm.k)*(clip(fc,fc1,swt7,time.k))/fn +C fc=1 +C fc1=1 +C fn=1 +C swt7=1970 +A fcm.k=table(fcmt,cr.k,0,5,1) +T fcmt=2.4/.6/.4/.3/.2 +A fpci.k=tabhl(fpcit,cira.k,0,6,1) +T fpcit=.5/1/1.4/1.7/1.9/2.05/2.2 +A cira.k=(cir.k)*(ciaf.k)/ciafn +C ciafn=.3 +A cir.k=(ci.k/p.k) +L ci.k=ci.j+(dt)*(cig.jk-cid.jk) +N ci=cii +C cii=.4e9 +R cig.kl=(p.k)*(cim.k)*(clip(cign,cign1,swt4,time.k)) +C cign=.05 +C cign1=.05 +C swt4=1970 +A cim.k=tabhl(cimt,msl.k,0,5,1) +T cimt=.1/1/1.8/2.4/2.8/3 +R cid.kl=(ci.k)*(clip(cidn,cidn1,swt5,time.k)) +C cidn=.025 +C cidn1=.025 +C swt5=1970 +A fpm.k=table(fpmt,polr.k,0,60,10) +T fpmt=1.02/.9/.65/.35/.2/.1/.05 +A polr.k=pol.k/pols +C pols=3.6e9 +L pol.k=pol.j+(dt)*(polg.jk-pola.jk) +N pol=poli +C poli=.2e9 +R polg.kl=(p.k)*(clip(poln,poln1,swt6,time.k))*(polcm.k) +C poln=1 +C poln1=1 +C swt6=1970 +A polcm.k=tabhl(polcmt,cir.k,0,5,1) +T polcmt=.05/1/3/5.4/7.4/8 +R pola.kl=pol.k/polat.k +A polat.k=table(polatt,polr.k,0,60,10) +T polatt=.6/2.5/8/11.5/15.5/20 +L ciaf.k=ciaf.j+(dt/ciaft)*((cfifr.j*ciqr.j)-ciaf.j) +N ciaf=ciaf1 +C ciaf1=.2 +C ciaft=15 +A cfifr.k=tabhl(cfifrt,fr.k,0,2,.5) +T cfifrt=1/.6/.3/.15/.1 +A ql.k=(qls)*(qlm.k)*(qlc.k)*(qlf.k)*(qlp.k) +C qls=1 +A qlm.k=tabhl(qlmt,msl.k,0,5,1) +T qlmt=.2/1/1.7/2.3/2.7/2.9 +A qlc.k=table(qlct,cr.k,0,5,.5) +T qlct=2/1.3/1/.75/.55/.45/.38/.3/.25/.22/.2 +A qlf.k=tabhl(qlft,fr.k,0,4,1) +T qlft=0/1/1.8/2.4/2.7 +A qlp.k=table(qlpt,polr.k,0,60,10) +T qlpt=1.04/.85/.6/.3/.15/.05/.02 +NOTE equation 42 located between eq. 4 and 9. +A nrmm.k=tabhl(nrmmt,msl.k,0,10,1) +T nrmmt=0/1/1.8/2.4/2.9/3.3/3.6/3.8/3.9/3.95/4 +NOTE input from eqn. 38 and 40 to eqn. 35 +A ciqr.k=tabhl(ciqrt,qlm.k/qlf.k,0,2,.5) +T ciqrt=.7/.8/1/1.5/2 +NOTE +NOTE control cards +NOTE +C dt=.1 +C length=2100 +N time=1900 +C prtper=4 +C pltper=4 +PLOT p=p(0,8e9)/polr=2(0,40)/ci=c(0,20e9)/ql=q(0,2)/nr=n(0,1e12) +note PLOT fr=f,msl=m,qlc=4,qlp=5(0,2)/ciaf=a(.2,.6) +PRINT p,nr,ci,pol,ciaf + + diff --git a/lang/dynamo/1.8.7/src/dyn.wohnen b/lang/dynamo/1.8.7/src/dyn.wohnen new file mode 100644 index 0000000..4e9b8b4 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.wohnen @@ -0,0 +1,105 @@ +note modell des wohnbaus in einer stadt +note +note siehe Goodman: Study Notes in System Dynamics, Seite 332 ff +note +note Bevölkerungs-Sektor +note +L pop.k=pop.j+dt*(imr.jk-omr.jk-ndr.jk) +N pop=popi +C popi=30.3 +note +note pop population (people) +note popi population initial value +note imr immigration rate (people/year) +note omr out-migration rate(people/year) +note +R imr.kl=nim*ammp.k*pop.k +C nim=.145 +note +note nim normal immigration (fraction/year) +note ammp attractiveness for migration multiplier perceived (dimensionless) +note +A ammp.k=smooth(amm.k,mpt) +C mpt=5 +note +note amm attractiveness for migration multiplier (dimensionless) +note mpt migrant perception time (years) +note +A amm.k=table(ammt,hr.k,0,2,.25) +T ammt=.05/.1/.2/.4/1/1.6/1.8/1.9/2 +note +note ammt attractiveness for migration multiplier table +note hr housing ratio (dimensionless) +note +A dmm.k=1/amm.k +note +note dmm departure migration multiplier (dimensionless) +note +R omr.kl=nom*dmm.k*pop.k +C nom=.02 +note +note nom normal out migration (fraction/year) +note +R ndr.kl=pop.k*drf +C drf=.025 +note +note ndr net death rate (people/year) +note drf death rate factor (fraction/year) +note************************************************************************* +note housing sector +note************************************************************************* +note +L h.k=h.j+dt*(hcr.jk-hdr.jk) +N h=hi +c hi=10 +note +note h housing (units) +note hcr housing construction rate (units/year) +note hdr housing demolition rate (units/year) +note hi initial value of houses (units) +note +R hcr.kl=nhc*hcm.k*lam.k*h.k +C nhc=.12 +note +note nhc normal housing construction (fraction/year) +note hcm housing construction multiplier (dimensionless) +note lam land availability multiplier (dimensionless) +note +A hcm.k=table(hcmt,hr.k,0,2,.25) +T hcmt=2.5/2.4/2.3/2/1/.37/.2/.1/.05 +note +A hr.k=h.k/hd.k +note +note hr housing ratio(dimensionless) +note hd housing desired (units) +note +A hd.k=pop.k*upp +C upp=.33 +note +note upp units per person (unit/person) +note +A lam.k=table(lamt,lfo.k,0,1,.25) +T lamt=1/.8/.5/.2/0 +note +note lfo land fraction occupied (dimensionless) +note +A lfo.k=H.k*lpu/land +C lpu=1 +C land=1500 +note +note lpu land per unit(acres/unit) +note land (acres) +note +R hdr.kl=h.k/alth +C alth=50 +note +note alth average lifetime of housing (years) +note*********************************************************************** +note control statements +note*********************************************************************** +note +plot h=h(0,2000)/pop=p(0,8000)/hcr=c,hdr=d(0,100) +C dt=1 +C length=200 +C pltper=2 + diff --git a/lang/dynamo/1.8.7/src/dyn.workfluc b/lang/dynamo/1.8.7/src/dyn.workfluc new file mode 100644 index 0000000..8016449 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.workfluc @@ -0,0 +1,44 @@ +NOTE +NOTE ******************************************************************* +NOTE MODEL OF WORKLOAD FLUCTUATIONS +NOTE ******************************************************************* +NOTE JOHN HENIZE 5.11.81 +NOTE ******************************************************************* +NOTE +L MM.K=MM.J+(DT)*(-MTR.J) MANPOWER IN MARKETING +N MM=4 MEN +L MP.K=MP.J+(DT)*(MTR.J) MANPOWER IN PRODUCTION +N MP=6 MEN +NOTE +L JIP.K=JIP.J+(DT)*(JS.J-JC.J) JOBS_IN_PROCESS +N JIP=6 JOBS +A JM.K=MM.K/MEJ JOBS MARKETED +C MEJ=2 MAN_MONTHS/JOB MARKETING EFFORT PER JOB +L JS.K=JS.J+(DT/SD)*(JM.J-JS.J) JOBS SOLD +N JS=JM +C SD=2 MONTH SALES DELAY +A JC.K=MP.K/AJS JOBS COMPLETED +C AJS=8 MAN_MONTH/JOB +NOTE +A MTR.K=(BA.K+PMA.K)*MTC.K MANPOWER TRANSFER RATE +A BA.K=MMJ*(JIP.K-DJIP) BACKLOG ADJUSTMENT +C DJIP=6 JOBS DESIRED JOBS IN PROCESS +C MMJ=.15 MEN PER MONTH PER JOB MEN REALLOCATED PER MONTH PER +NOTE +A MTC.K=CLIP(MMC.K,PMC.K,BA.K,0) MANPOWER TRANSFER CONSTRAINT +A MMC.K=MMR.K MARKETING MANPOWER CONSTRAINT +A MMR.K=MM.K/(MM.K+MP.K) MARKETING MANPOWER RATIO +A PMC.K=PMR.K*PMR.K PRODUCTION MANPOWER CONSTRAINT +A PMR.K=MP.K/(MM.K+MP.K) PRODUCTION MANPOWER RATIO +NOTE +A PMA.K=SWITCH(0,PMA1.K,SW) PRODUCTION MANPOWER ADJUSTMENT +C SW=0 +A PMA1.K=(DMP.K-MP.K)/MAT +A DMP.K=JS.K*AJS DESIRED MANPOWER IN PRODUCTION +C MAT=10 MONTHS MANPOWER ADJUSTMENT TIME +NOTE +C DT=.2 +C LENGTH=120 +C PLTPER=6 +PLOT MM=M,MP=P(0,10)/JIP=J(0,20) + diff --git a/lang/dynamo/1.8.7/src/dyn.wurzel b/lang/dynamo/1.8.7/src/dyn.wurzel new file mode 100644 index 0000000..7f8e6e0 --- /dev/null +++ b/lang/dynamo/1.8.7/src/dyn.wurzel @@ -0,0 +1,14 @@ +note theon von smyrnas verfahren +note +l uj.k=u.j +l u.k=u.j+2*v.j +l v.k=v.j+uj.j +n uj=1 +n u=1 +n v=1 +a wurzelzwei.k=u.k/v.k +print u,v,wurzelzwei +c dt=1 +c length=20 +c prtper=1 + diff --git a/lang/dynamo/1.8.7/src/out.world b/lang/dynamo/1.8.7/src/out.world new file mode 100644 index 0000000..39859ce --- /dev/null +++ b/lang/dynamo/1.8.7/src/out.world @@ -0,0 +1,43 @@ +PAGE 1 : WORLD DYNAMICS W5 +P=P(0,8E9)/POLR=2(0,40)/CI=C(0,20E9)/QL=Q(0,2)/NR=N(0,1000E9) + 0.0 2.000000e9 4.000000e9 6.000000e9 8.000000e9p + 0.0 10. 20. 30. 40.2 + 0.0 5.000000e9 1.000000e10 1.500000e10 2.000000e10c + 0.0 .5 1. 1.5 2.q + 0.0 2.500000e11 5.000000e11 7.500000e11 1.000000e12n +1900. 2c________p__.__q_________.____________._______n____. +1902. 2c p . q . . n . +1908. 2c p . q . . n . +1914. 2c p . q . . n . +1920. 2 c p. q . . n . +1926. 2_c__________p____________q____________.______n_____. +1932. 2 c .p .q . n . +1938. 2 c . p .q . n . +1944. 2 c . p . q . n . +1950. 2 c . p Ω§Ω§ . n . +1956. 2______c_____.______p_____.q___________.___n________. +1962. 2 c . p q . n . +1968. 2 c . p q. . n . +1974. .2 c . p. .n .q +1980. .2 c. q.p n . +1986. .2___________.c_________q_.__p_______n_.____________. +1992. . 2 . c q . p n . . +1998. . 2 . c q . p n . . +2004. .__2_________.____c_q_____._____np_____.____________. +2010. . 2 . c . n p . .q +2016. . 2 . q c . n p . . +2022. . 2 . q c . n p . . +2028. . 2 . q c n p . . +2034. ._____2______.___q____c_n_._______p____.____________. +2040. . 2 . q cn . p . . +2046. . 2 . q c . p . .n +2052. . 2 . q nc . p . . +2058. . 2 . q n c . p . . +2064. ._____2______.__q_n__c____.__p_________.____________. +2070. . 2 . q n c . p . . +2076. . 2 . qn c .p . . +2082. . 2 . qn c .p . . +2088. . 2 . q c p . .n +2094. .__2_________.qnc________p.____________.____________. +2100. . 2 .qc p . . .n + diff --git a/lang/dynamo/1.8.7/src/ruestungsgleichgewicht.const b/lang/dynamo/1.8.7/src/ruestungsgleichgewicht.const Binary files differnew file mode 100644 index 0000000..d38858b --- /dev/null +++ b/lang/dynamo/1.8.7/src/ruestungsgleichgewicht.const diff --git a/lang/dynamo/1.8.7/src/stabileruestung.const b/lang/dynamo/1.8.7/src/stabileruestung.const Binary files differnew file mode 100644 index 0000000..9d64330 --- /dev/null +++ b/lang/dynamo/1.8.7/src/stabileruestung.const diff --git a/lang/lisp/1.7.2/src/lisp.1 b/lang/lisp/1.7.2/src/lisp.1 new file mode 100644 index 0000000..6851947 --- /dev/null +++ b/lang/lisp/1.7.2/src/lisp.1 @@ -0,0 +1,1305 @@ +PACKET lisp heap and oblist management (* Autor: J.Durchholz *)
+ (* Datum: 09.05.1984 *)
+ DEFINES (* Version 1.7.2 *)
+ (* hey 25.2.83 *)
+ initialize lisp system,
+ dump lisp heap,
+ lisp storage,
+ collect lisp heap garbage,
+ SYM,
+ :=,
+ nil,
+ pname,
+ head,
+ set head,
+ tail,
+ set tail,
+ cons,
+ eq,
+ equal,
+ null,
+ atom,
+ is named atom,
+ begin oblist dump,
+ next atom,
+ new atom,
+ create atom,
+ delete atom,
+ begin property list dump,
+ next property,
+ add property,
+ alter property,
+ property,
+ delete property,
+ property exists,
+ add flag,
+ flag,
+ delete flag,
+ text,
+ is text,
+ character,
+ is character,
+ sym character,
+ int 1,
+ int 2,
+ is int pair,
+ sym:
+
+
+(* NOTE: All internal routines are prefixed by x *)
+
+
+(***************************** heap management ****************************)
+
+LET
+ max size = 32767,
+ NODE = STRUCT (INT status,
+ head, tail);
+LET HEAP = STRUCT (INT size,
+ ROW max size NODE node);
+
+
+BOUND HEAP VAR heap;
+
+
+PROC initialize lisp system (DATASPACE CONST ds):
+ IF type (ds) < 0 THEN
+ heap := ds;
+ x initialize oblist and heap size;
+ create atom ("NIL");
+ create atom ("PNAME");
+ ELSE
+ heap := ds
+ FI
+END PROC initialize lisp system;
+
+
+PROC dump lisp heap (FILE VAR f):
+ put line (f, "Groesse :" + text (CONCR (heap).size));
+ line (f);
+ put (CONCR (heap).size);
+ BOOL VAR is char := FALSE;
+ INT VAR i;
+ FOR i FROM 1 UPTO CONCR (heap).size REP
+ cout (i);
+ dump ith node
+ PER.
+
+dump ith node:
+ put (f, text (i, 6));
+ put (f, status);
+ put (f, head);
+ put (f, tail);
+ line (f).
+
+status:
+ SELECT ith node.status OF
+ CASE atomic : "ATOMIC............"
+ CASE non atomic : "NON ATOMIC........"
+ CASE oblist bone : "OBLIST BONE......."
+ CASE property indicator : "PROPERTY INDICATOR"
+ CASE property root : "PROPERTY ROOT....."
+ CASE flag indicator : "FLAG INDICATOR...."
+ CASE text data : "TEXT DATA........."
+ CASE character data : is char := TRUE; "CHARACTER DATA...."
+ CASE int data : "INT DATA.........."
+ OTHERWISE "????." + text (ith node.status, 6) + ".????"
+ END SELECT.
+
+head:
+ maybe a code + text (ith node.head, 6).
+
+maybe a code:
+ IF is char THEN
+ is char := FALSE;
+ IF ith node.head > 31 AND 128 > ith node.head THEN
+ " " + code (ith node.head) + " "
+ ELSE
+ " "
+ FI
+ ELSE
+ " "
+ FI.
+
+tail:
+ text (ith node.tail, 6).
+
+ith node:
+ CONCR (heap).node (i).
+
+END PROC dump lisp heap;
+
+
+PROC lisp storage (INT VAR size, used):
+ size := max size;
+ used := CONCR (heap).size
+END PROC lisp storage;
+
+
+PROC collect lisp heap garbage:
+ mark all used nodes;
+ transfer all used high address nodes to unused low address nodes;
+ adjust all pointers to cleared high address area and unmark all nodes;
+ adjust size.
+
+mark all used nodes:
+ INT VAR i;
+ FOR i FROM 2 UPTO 28 REP
+ x mark (i)
+ PER.
+
+transfer all used high address nodes to unused low address nodes:
+ INT VAR high address :: CONCR (heap).size + 1,
+ low address :: 0;
+ REP
+ find next lower used high address node;
+ IF no used high address node found THEN
+ LEAVE transfer all used high address nodes to unused low address nodes
+ FI;
+ find next higher unused low address node;
+ IF no unused low address node found THEN
+ LEAVE transfer all used high address nodes to unused low address nodes
+ FI;
+ transfer high address node to low address node
+ PER.
+
+find next lower used high address node:
+ REP
+ high address DECR 1
+ UNTIL high address node marked PER.
+
+high address node marked:
+ high address node.status < 0.
+
+no used high address node found:
+ low address = high address.
+
+find next higher unused low address node:
+ REP
+ low address INCR 1
+ UNTIL low address node not marked OR low address = high address PER.
+
+low address node not marked:
+ low address node.status > 0.
+
+no unused low address node found :
+ low address = high address.
+
+transfer high address node to low address node:
+ low address node.status := high address node.status;
+ low address node.head := high address node.head;
+ low address node.tail := high address node.tail;
+ high address node.head := low address.
+
+adjust all pointers to cleared high address area and unmark all nodes:
+ (* 'high address' should now point to the last node of the used area *)
+ FOR low address FROM 1 UPTO high address REP
+ unmark low address node;
+ SELECT low address node.status OF
+ CASE oblist bone: adjust head
+ CASE atomic,
+ non atomic,
+ property indicator,
+ property root,
+ flag indicator: adjust head; adjust tail
+ CASE text data, character data: adjust tail
+ CASE int data:
+ OTHERWISE x lisp error ("Status " + text (low address node.status) +
+ " gefunden bei pointer Justage")
+ END SELECT
+ PER.
+
+unmark low address node:
+ low address node.status := - low address node.status.
+
+adjust head:
+ IF low address node.head > high address THEN
+ low address node.head := node (low address node.head).head
+ FI.
+
+adjust tail:
+ IF low address node.tail > high address THEN
+ low address node.tail := node (low address node.tail).head
+ FI.
+
+adjust size:
+ CONCR (heap).size := high address.
+
+low address node:
+ node (low address).
+
+high address node:
+ node (high address).
+
+node:
+ CONCR (heap).node.
+
+END PROC collect lisp heap garbage;
+
+
+PROC x mark (INT CONST ptr):
+ IF node not yet marked THEN
+ mark node;
+ SELECT - ptr node.status OF
+ CASE oblist bone: x mark (ptr node.head)
+ CASE atomic,
+ non atomic,
+ property indicator,
+ property root,
+ flag indicator: x mark (ptr node.head); x mark (ptr node.tail)
+ CASE text data, character data: x mark (ptr node.tail)
+ CASE int data:
+ OTHERWISE error stop ("Status " + text (- ptr node.status) +
+ " gefunden beim Markieren")
+ END SELECT
+ FI.
+
+
+node not yet marked:
+ ptr node.status > 0.
+
+mark node:
+ ptr node.status := - ptr node.status.
+
+ptr node:
+ CONCR (heap).node (ptr)
+
+END PROC x mark;
+
+
+TYPE SYM = INT;
+
+
+OP := (SYM VAR left, SYM CONST right):
+ CONCR (left) := CONCR (right)
+END OP :=;
+
+
+LET atomic = 1,
+ non atomic = 2,
+ oblist bone = 3,
+ property indicator = 4,
+ property root = 5,
+ flag indicator = 6,
+ text data = 7,
+ character data = 8,
+ int data = 9;
+
+SYM CONST nil :: SYM :(35), (* 'x initialize oblist and heap size' will *)
+ pname :: SYM :(44); (* place the atom NIL at node 35 and PNAME *)
+ (* at node 44 *)
+
+
+(***************************** basic functions ****************************)
+
+
+SYM PROC head (SYM CONST sym):
+ SELECT status of sym OF
+ CASE atomic: error stop ("Atome haben keinen head"); nil
+ CASE non atomic: SYM :(head of sym)
+ CASE oblist bone,
+ property indicator,
+ property root,
+ flag indicator : x lisp error ("Versteckter Knoten, Type:" +
+ text (status of sym));
+ nil
+ CASE text data,
+ character data,
+ int data : error stop ("Daten haben keinen head"); nil
+ OTHERWISE x lisp error ("Illegaler Status " + text (status of sym));
+ nil
+ END SELECT.
+
+status of sym:
+ sym node.status.
+
+head of sym:
+ sym node.head.
+
+sym node:
+ CONCR (heap).node (CONCR (sym))
+
+END PROC head;
+
+
+SYM PROC x head (SYM CONST sym):
+ SYM :(CONCR (heap).node (CONCR (sym)).head)
+END PROC x head;
+
+
+PROC set head (SYM CONST sym, new head):
+ SELECT status of sym OF
+ CASE atomic: errorstop ("Atome haben keinen head")
+ CASE non atomic: head of sym := CONCR (new head)
+ CASE oblist bone,
+ property indicator,
+ property root,
+ flag indicator : x lisp error ("Versteckter Knoten, Type:" +
+ text (status of sym))
+ CASE text data,
+ character data,
+ int data : error stop ("Daten haben keinen head")
+ OTHERWISE x lisp error ("Illegaler Status " + text (status of sym))
+ END SELECT.
+
+status of sym:
+ sym node.status.
+
+head of sym:
+ sym node.head.
+
+sym node:
+ CONCR (heap).node (CONCR (sym)).
+
+END PROC set head;
+
+
+PROC x set head (SYM CONST sym, new head):
+ CONCR (heap).node (CONCR (sym)).head := CONCR (new head)
+END PROC x set head;
+
+
+SYM PROC tail (SYM CONST sym):
+ SELECT status of sym OF
+ CASE atomic: error stop ("Atome haben keinen tail"); nil
+ CASE non atomic: SYM :(tail of sym)
+ CASE oblist bone,
+ property indicator,
+ flag indicator : x lisp error ("Versteckter Knoten:" +
+ text (status of sym));
+ nil
+ CASE text data,
+ character data,
+ int data : error stop ("Daten haben keinen tail"); nil
+ OTHERWISE x lisp error ("Illegaler Status: "+ text (status of sym));
+ nil
+ END SELECT.
+
+status of sym:
+ sym node.status.
+
+tail of sym:
+ sym node.tail.
+
+sym node:
+ CONCR (heap).node (CONCR (sym)).
+
+END PROC tail;
+
+
+SYM PROC x tail (SYM CONST sym):
+ SYM :(CONCR (heap).node (CONCR (sym)).tail)
+END PROC x tail;
+
+
+PROC set tail (SYM CONST sym, new tail):
+ SELECT status of sym OF
+ CASE atomic: error stop ("Atome haben keinen tail")
+ CASE non atomic: tail of sym := CONCR (new tail)
+ CASE oblist bone,
+ property indicator,
+ property root,
+ flag indicator : x lisp error ("Versteckter Knoten, Type: " +
+ text (status of sym))
+ CASE text data,
+ character data,
+ int data : error stop ("Daten tails sind unveraenderbar")
+ OTHERWISE x lisp error ("Illegaler Status: " + text (status of sym))
+ END SELECT.
+
+status of sym:
+ sym node.status.
+
+tail of sym:
+ sym node.tail.
+
+sym node:
+ CONCR (heap).node (CONCR (sym)).
+
+END PROC set tail;
+
+
+PROC x set tail (SYM CONST sym, new tail):
+ CONCR (heap).node (CONCR (sym)).tail := CONCR (new tail)
+END PROC x set tail;
+
+
+SYM PROC cons (SYM CONST head, tail):
+ SYM VAR result;
+ search free node;
+ result node.status := non atomic;
+ result node.head := CONCR (head);
+ result node.tail := CONCR (tail);
+ result.
+
+search free node:
+ IF CONCR (heap).size = max size THEN
+ error stop ("LISP Heap Ueberlauf");
+ LEAVE cons WITH nil
+ ELSE
+ CONCR (heap).size INCR 1;
+ CONCR (result) := CONCR (heap).size; cout(CONCR(result))
+ FI.
+
+result node:
+ CONCR (heap).node (CONCR (result)).
+
+END PROC cons;
+
+
+BOOL PROC eq (SYM CONST sym 1, sym 2):
+ CONCR (sym 1) = CONCR (sym 2)
+END PROC eq;
+
+
+BOOL PROC equal (SYM CONST sym 1, sym 2):
+ eq (sym 1, sym 2) COR have same value.
+
+have same value:
+ IF sym 1 node.status <> sym 2 node.status THEN
+ FALSE
+ ELSE
+ SELECT sym 1 node.status OF
+ CASE atomic: FALSE
+ CASE non atomic: equal (head (sym 1), head (sym 2)) CAND
+ equal (tail (sym 1), tail (sym 2))
+ CASE oblist bone,
+ property indicator,
+ property root,
+ flag indicator: x lisp error ("Versteckter Knoten, Type: " +
+ text (x status (sym 1))); FALSE
+ CASE text data: equal texts
+ CASE character data: sym 1 node.head = sym 2 node.head
+ CASE int data: sym 1 node.head = sym 2 node.head AND
+ sym 1 node.tail = sym 2 node.tail
+ OTHERWISE x lisp error ("Ilegaler Status " + text (x status (sym 1)));
+ FALSE
+ END SELECT
+ FI.
+
+equal texts:
+ equal length CAND equal character sequence.
+
+equal length:
+ eq (x head (sym 1), x head (sym 2)).
+
+equal character sequence:
+ SYM VAR actual sym 1 character :: sym 1,
+ actual sym 2 character :: sym 2;
+ INT VAR i;
+ FOR i FROM 1 UPTO sym 1 node. head REP
+ actual sym 1 character := x tail (actual sym 1 character);
+ actual sym 2 character := x tail (actual sym 2 character);
+ IF eq (actual sym 1 character, actual sym 2 character) THEN
+ LEAVE equal character sequence WITH TRUE
+ FI;
+ IF x status (actual sym 1 character) <> character data OR
+ x status (actual sym 2 character) <> character data THEN
+ x lisp error ("Ungueltiges Zeichen im text");
+ LEAVE equal character sequence WITH FALSE
+ FI;
+ IF CONCR (x head (actual sym 1 character)) <>
+ CONCR (x head (actual sym 2 character)) THEN
+ LEAVE equal character sequence WITH FALSE
+ FI
+ PER;
+ TRUE.
+
+sym 1 node:
+ CONCR (heap).node (CONCR (sym 1)).
+
+sym 2 node:
+ CONCR (heap).node (CONCR (sym 2)).
+
+END PROC equal;
+
+
+BOOL PROC null (SYM CONST sym):
+ CONCR (sym) = CONCR (nil)
+END PROC null;
+
+
+BOOL PROC atom (SYM CONST sym):
+ SELECT x status (sym) OF
+ CASE atomic,
+ text data,
+ character data,
+ int data: TRUE
+ CASE non atomic: FALSE
+ CASE oblist bone,
+ property indicator,
+ property root,
+ flag indicator : x lisp error ("Versteckter Knoten, Type:" +
+ text (x status (sym))); TRUE
+ OTHERWISE x lisp error ("Illegaler Status " +
+ text (x status (sym))); TRUE
+ END SELECT
+END PROC atom;
+
+
+BOOL PROC is named atom (SYM CONST sym):
+ x status (sym) = atomic
+END PROC is named atom;
+
+
+(*------------------- internal heap management routines ------------------*)
+
+
+SYM PROC x new node (INT CONST status, head, tail):
+ IF CONCR (heap).size = max size THEN
+ error stop ("LISP Heap Ueberlauf"); nil
+ ELSE
+ CONCR (heap).size INCR 1;
+ new node.status := status;
+ new node.head := head;
+ new node.tail := tail;
+ SYM :(CONCR (heap).size)
+ FI.
+
+new node:
+ node (CONCR (heap).size).
+
+node:
+ CONCR (heap).node.
+
+END PROC x new node;
+
+
+INT PROC x status (SYM CONST sym):
+ CONCR (heap).node (CONCR (sym)).status
+END PROC x status;
+
+
+(**************************** oblist management ***************************)
+
+
+(* Oblist organization:
+
+(NOTE:
+
+ +-----------------+
+ l <status> l
+ All nodes are represented as +--------+--------+ in all comments
+ l <head> l <tail> l of this packet.
+ +--------+--------+
+
+END OF NOTE)
+
+
+The 'oblist' (object list) is organized as follows:
+
+ +-------------+
+ l oblist bone l
+ +------+------+ +--> list of all atoms whose print names begin with "@"
+ l o l XXXX l l
+ +---+--+------+ l
+ +------------+
+ +-------------+
+ l oblist bone l
+ +------+------+ +--> list of all atoms whose print names begin with "A"
+ l o l XXXX l l
+ +---+--+------+ l
+ +------------+
+ .
+ .
+ .
+
+ +-------------+
+ l oblist bone l
+ +------+------+ +--> list of all atoms whose print names begin with "Z"
+ l o l XXXX l l
+ +---+--+------+ l
+ +------------+
+
+
+These nodes with status 'oblist bone' form the oblist skeleton. As long as
+the lisp heap exists, they are stored contiguously in nodes 2 - 28; they
+cannot be changed directly by the user. This way of storing the oblist
+skeleton allows a hashing scheme to be applied when searching for an atom
+with a given name. The hash width of 27 is the smallest one thas distributes
+all atoms according to their character; with a smaller hash size, two or
+more lists would be merged, with the effect that some of the atom lists
+would contain atoms beginning with different characters.
+
+
+The list of all atoms whose print names begin with a certain character
+is organized as follows:
+
+ +-------------+
+ l atomic l
+ +------+------+
+ l o l o---+--> property list of first atom
+ +---+--+------+
+ l
+ V
+ +-------------+
+ l atomic l
+ +------+------+
+ l o l o---+--> property list of 2nd atom
+ +---+--+------+
+ l
+ V
+ .
+ .
+ .
+
+ l
+ V
+ +-------------+
+ l atomic l
+ +------+------+
+ l o l o---+--> property list of last atom
+ +---+--+------+
+ l
+ V
+ oblist bone where the atom list began
+
+
+These lists cannot be acessed directly by the user, too.
+*)
+
+
+
+PROC x initialize oblist and heap size:
+ node (1).status := text data;
+ node (1).head := 32 (* blank *);
+ node (1).tail := 1;
+ INT VAR i;
+ FOR i FROM 2 UPTO 28 REP
+ node (i).status := oblist bone;
+ node (i).head := i
+ PER;
+ CONCR (heap).size := 28.
+
+node:
+ CONCR (heap).node.
+
+END PROC x initialize oblist and heap size;
+
+
+(*++++++++++++++++++++++++++++++ oblist dump +++++++++++++++++++++++++++++*)
+
+
+SYM VAR actual oblist bone :: SYM :(0),
+ actual atom :: SYM :(0);
+
+
+PROC begin oblist dump:
+ actual oblist bone := SYM :(2);
+ actual atom := SYM :(2)
+END PROC begin oblist dump;
+
+
+SYM PROC next atom:
+ actual atom := x head (actual atom);
+ WHILE no more atoms in this atom list REP
+ try next oblist bone
+ PER;
+ actual atom.
+
+no more atoms in this atom list:
+ (* NIL is given as last atom when 'next atom' is called repeatedly, so *)
+ (* it can serve as a terminator. So NIL "does not count" if it is *)
+ (* encountered during one of the calls. *)
+ IF null (actual atom) THEN
+ actual atom := x head (actual atom)
+ FI;
+ eq (actual atom, actual oblist bone).
+
+try next oblist bone:
+ IF actual oblist bone is last oblist bone THEN
+ actual atom := SYM :(2);
+ LEAVE next atom WITH nil
+ FI;
+ CONCR (actual oblist bone) INCR 1;
+ actual atom := x head (actual oblist bone).
+
+actual oblist bone is last oblist bone:
+ CONCR (actual oblist bone) = 28.
+
+END PROC next atom;
+
+
+(*+++++++++++++++++++++++ atom search and creation +++++++++++++++++++++++*)
+
+
+SYM VAR predecessor, result;
+ (* Variables used for communication between the internal search *)
+ (* procedures and the procedures calling them. *)
+
+
+SYM PROC atom (TEXT CONST name):
+ x search atom (name);
+ IF atom not already existing THEN
+ nil
+ ELSE
+ result
+ FI.
+
+atom not already existing:
+ x status (result) = oblist bone.
+
+END PROC atom;
+
+
+SYM PROC new atom (TEXT CONST name):
+ x search atom (name);
+ IF atom not already existing THEN
+ x create new atom (name);
+ FI;
+ result.
+
+atom not already existing:
+ x status (result) = oblist bone.
+
+END PROC new atom;
+
+
+PROC create atom (TEXT CONST name):
+ x search atom (name);
+ IF atom already existing THEN
+ error stop ("Atom " + name + " existiert bereits")
+ ELSE
+ x create new atom (name)
+ FI.
+
+atom already existing:
+ x status (result) <> oblist bone.
+
+END PROC create atom;
+
+
+PROC delete atom (SYM CONST atom):
+ IF is named atom (atom) THEN
+ IF null (atom) OR eq (atom, pname) THEN
+ error stop ("Dies Atom darf nicht geloescht werden")
+ ELSE
+ search predecessor;
+ delete atom from atom list
+ FI
+ ELSE
+ error stop ("Nur benannte Atome k”nnen geloescht werden")
+ FI.
+
+search predecessor:
+ predecessor := x head (atom);
+ WHILE NOT eq (x head (predecessor), atom) REP
+ predecessor := x head (predecessor)
+ PER.
+
+delete atom from atom list:
+ x set head (predecessor, x head (atom)).
+
+END PROC delete atom;
+
+
+PROC x search atom (TEXT CONST name):
+ CONCR (result) := (code (name SUB 1) + 17) MOD 27 + 2;
+ (* This formula places the list of atoms beginning with "@" at the *)
+ (* first oblist bone, the list of atoms beginning with "A" at the *)
+ (* at the second one, and so on. (See also the big comment in lines *)
+ (* 600 - 700) *)
+ REP
+ predecessor := result;
+ result := x head (predecessor);
+ UNTIL end of atom list reached COR right atom found PER.
+
+end of atom list reached:
+ x status (result) = oblist bone.
+
+right atom found:
+ SYM VAR actual character node := property (result, pname);
+ IF NOT is text (actual character node) THEN
+ x lisp error ("Namen erwartet");
+ LEAVE right atom found WITH FALSE
+ FI;
+ IF CONCR (x head (actual character node)) <> length (name) THEN
+ FALSE
+ ELSE
+ INT VAR i;
+ FOR i FROM 1 UPTO length (name) REP
+ to next character node;
+ check wether is character data node;
+ check wether character matches;
+ PER;
+ TRUE
+ FI.
+
+to next character node:
+ actual character node := x tail (actual character node).
+
+check wether is character data node:
+ IF x status (actual character node) <> character data THEN
+ x lisp error ("Zeichenkette erwartet");
+ LEAVE right atom found WITH FALSE
+ FI.
+
+check wether character matches:
+ IF code (name SUB i) <> CONCR (x head (actual character node)) THEN
+ LEAVE right atom found WITH FALSE
+ FI.
+
+END PROC x search atom;
+
+
+PROC x create new atom (TEXT CONST name):
+ (* It is necessary that 'x search atom' has been executed before *)
+ (* calling 'x create new atom' because this procedure relies on the *)
+ (* value of 'predecessor'. *)
+ enable stop;
+ SYM CONST sym name :: sym (name);
+ IF CONCR (heap).size + 3 > max size THEN
+ error stop ("LISP Heap Ueberlauf")
+ FI;
+ result := newly created atom;
+ x set head (predecessor, result).
+
+newly created atom:
+ x new node (atomic, CONCR (oblist bone node), CONCR (property list)).
+
+oblist bone node:
+ x head (predecessor).
+
+property list:
+ x new node (property indicator, CONCR (pname), property root node).
+
+property root node:
+ CONCR (x new node (property root, CONCR (sym name), CONCR (nil))).
+
+END PROC x create new atom;
+
+
+(************************* property list handling *************************)
+
+(*
+The property lists consist of chained units of the structure
+
+ +--------------------+ +---------------+
+ l property indicator l l property root l
+ +----------+---------+ +-------+-------+
+ l o l o----+-->l o l o---+--> . . .
+ +----+-----+---------+ +---+---+-------+
+ l l
+ V V
+ property id property
+
+
+or
+
+ +----------------+
+ l flag indicator l
+ +--------+-------+
+ l o l o---+--> . . .
+ +---+----+-------+
+ l
+ V
+ flag id
+
+
+
+The property lists cannot be altered or read directly, too.
+
+For property list handling there exist procedures that insert, change, read
+and delete properties resp. flags. Thus, the only thing that can be done
+with any property of an atom without using these special procedures, is
+comparing to or 'cons'ing with some other S-expression.
+At any given time the property list of any atom (including 'NIL') contains
+the property 'PNAME' giving the print name of the atom, stored as a list of
+characters. This special property cannot be altered, overwritten by 'add
+property' or deleted.
+*)
+
+
+(*++++++++++++++++++++++++++ property list dump ++++++++++++++++++++++++++*)
+
+
+SYM VAR actual property list node :: nil;
+
+
+PROC begin property list dump (SYM CONST atom):
+ actual property list node := x tail (atom)
+END PROC begin property list dump;
+
+
+PROC next property (SYM VAR property id, property):
+ IF null (actual property list node) THEN
+ property id := nil;
+ property := nil
+ ELSE
+ SELECT x status (actual property list node) OF
+ CASE flag indicator: get flag id
+ CASE property indicator: get property id and property
+ OTHERWISE x lisp error ("Flagge oder Eigenschaft erwartet und nicht: "
+ + text (x status (actual property list node)))
+ END SELECT
+ FI.
+
+get flag id:
+ property id := x head (actual property list node);
+ actual property list node := x tail (actual property list node);
+ property := nil.
+
+get property id and property:
+ property id := x head (actual property list node);
+ actual property list node := x tail (actual property list node);
+ IF x status (actual property list node) = property root THEN
+ property := x head (actual property list node);
+ actual property list node := x tail (actual property list node)
+ ELSE
+ x lisp error ("Eigenschaftswurzel erwartet, nicht:" +
+ text (x status (actual property list node)));
+ property := nil
+ FI.
+
+END PROC next property;
+
+
+(*+++++++++++++++++++++++++++++ properties +++++++++++++++++++++++++++++++*)
+
+
+SYM VAR last atom :: SYM :(0),
+ p list predecessor,
+ p list result;
+
+
+PROC add property (SYM CONST atom, property id, property):
+ IF eq (property id, pname) THEN
+ errorstop ("Der PNAME eines Atoms darf nicht versteckt sein")
+ ELSE
+ IF CONCR (heap).size + 2 > max size THEN
+ error stop ("LISP Heap Ueberlauf");
+ LEAVE add property
+ FI;
+ x set tail (atom, new property plus old property list);
+ IF eq (atom, last atom) AND
+ eq (property id, x head (p list result)) THEN
+ p list predecessor := atom;
+ p list result := x tail (atom)
+ FI
+ FI.
+
+new property plus old property list:
+ x new node (property indicator,
+ CONCR (property id), CONCR (property root plus old property list)).
+
+property root plus old property list:
+ x new node (property root, CONCR (property), CONCR (old property list)).
+
+old property list:
+ x tail (atom)
+
+END PROC add property;
+
+
+PROC alter property (SYM CONST atom, property id, new property):
+ IF eq (property id, pname) THEN
+ error stop ("Namen kann man nicht aendern")
+ ELSE
+ x search property id (atom, property id);
+ IF null (p list result) THEN
+ error stop ("Eigenschaft existiert nicht")
+ ELSE
+ x set head (x tail (p list result), new property)
+ FI
+ FI
+END PROC alter property;
+
+
+SYM PROC property (SYM CONST atom, property id):
+ x search property id (atom, property id);
+ IF null (p list result) THEN
+ nil
+ ELSE
+ x head (x tail (p list result))
+ FI
+END PROC property;
+
+
+PROC delete property (SYM CONST atom, property id):
+ IF eq (property id, pname) THEN
+ errorstop ("Der Name eines Atoms darf nicht geloescht werden")
+ ELSE
+ x search property id (atom, property id);
+ IF NOT null (p list result) THEN
+ x set tail (p list predecessor, x tail (x tail (p list result)));
+ last atom := SYM :(0)
+ FI
+ FI
+END PROC delete property;
+
+
+BOOL PROC property exists (SYM CONST atom, property id):
+ x search property id (atom, property id);
+ NOT null (p list result)
+END PROC property exists;
+
+
+PROC x search property id (SYM CONST atom, property id):
+ IF eq (last atom, atom) AND eq (x head (p list result), property id) THEN
+ LEAVE x search property id
+ FI;
+ last atom := atom;
+ p list predecessor := atom;
+ REP
+ p list result := x tail (p list predecessor);
+ IF end of property list THEN
+ last atom := SYM :(0);
+ LEAVE x search property id
+ FI;
+ SELECT x status (p list result) OF
+ CASE flag indicator: p list predecessor := p list result
+ CASE property indicator: check wether property root node follows;
+ IF correct property id found THEN
+ LEAVE x search property id
+ ELSE
+ p list predecessor := xtail (p list result)
+ FI
+ CASE property root: xlisperror("Unordentliche Eigenschaftwurzel");
+ p list result := nil;
+ last atom := SYM :(0);
+ LEAVE x search property id
+ OTHERWISE x lisp error ("Eigenschaften erwartet und nicht: " +
+ text (x status (p list result)));
+ p list result := nil;
+ last atom := SYM :(0);
+ LEAVE x search property id
+ END SELECT
+ PER.
+
+end of property list:
+ null (p list result).
+
+check wether property root node follows:
+ IF x status (x tail (p list result)) <> property root THEN
+ x lisp error ("Eigenschaftswurzel erwartet");
+ p list result := nil;
+ last atom := SYM :(0);
+ LEAVE x search property id
+ FI.
+
+correct property id found:
+ eq (x head (p list result), property id).
+
+END PROC x search property id;
+
+
+(*++++++++++++++++++++++++++++++++ flags +++++++++++++++++++++++++++++++++*)
+
+
+PROC add flag (SYM CONST atom, flag id):
+ enable stop;
+ x set tail (atom, new flag plus old property list).
+
+new flag plus old property list:
+ x new node (flag indicator, CONCR (flag id), old property list).
+
+old property list:
+ CONCR (x tail (atom))
+
+END PROC add flag;
+
+
+BOOL PROC flag (SYM CONST atom, flag id):
+ x search flag id (atom, flag id);
+ NOT null (result)
+END PROC flag;
+
+
+PROC delete flag (SYM CONST atom, flag id):
+ x search flag id (atom, flag id);
+ IF NOT (is error COR null (result)) THEN
+ x set tail (predecessor, x tail (result))
+ FI
+END PROC delete flag;
+
+
+PROC x search flag id (SYM CONST atom, flag id):
+ predecessor := atom;
+ REP
+ result := x tail (predecessor);
+ IF end of property list THEN
+ LEAVE x search flag id
+ FI;
+ SELECT x status (result) OF
+ CASE property root, property indicator: predecessor := result
+ CASE flag indicator: IF correct flag id found THEN
+ LEAVE x search flag id
+ ELSE
+ predecessor := result
+ FI
+ OTHERWISE x lisp error ("Eigenschaften erwartet und nicht:" +
+ text (x status (result)));
+ result := nil;
+ LEAVE x search flag id
+ END SELECT
+ PER.
+
+end of property list:
+ null (result).
+
+correct flag id found:
+ eq (x head (result), flag id).
+
+END PROC x search flag id;
+
+
+(****** Conversion of non-LISP data to LISP structures and vice versa *****)
+
+
+TEXT PROC text (SYM CONST sym):
+ IF is text (sym) THEN
+ TEXT VAR result := "";
+ SYM VAR actual node :: sym;
+ INT VAR i;
+ FOR i FROM 1 UPTO CONCR (x head (sym)) REP
+ actual node := x tail (actual node);
+ result CAT actual character
+ PER;
+ result
+ ELSE
+ error stop ("ist kein text");
+ ""
+ FI.
+
+actual character:
+ IF x status (actual node) <> character data THEN
+ x lisp error ("Zeichenfolge erwartet");
+ LEAVE text WITH result
+ FI;
+ code (CONCR (x head (actual node))).
+
+END PROC text;
+
+
+BOOL PROC is text (SYM CONST sym):
+ x status (sym) = text data
+END PROC is text;
+
+
+SYM PROC sym (TEXT CONST text):
+ SYM VAR result :: x new node (text data,
+ length (text), CONCR (nil)),
+ actual character node :: result;
+ INT VAR length of text;
+ ignore blanks at end of text;
+ INT VAR i;
+ FOR i FROM 1 UPTO length of text REP
+ x set tail (actual character node, new next character node);
+ actual character node := x tail (actual character node)
+ PER;
+ result.
+
+ignore blanks at end of text:
+ FOR length of text FROM length (text) DOWNTO 0 REP
+ IF (text SUB length of text) <> " " THEN
+ LEAVE ignore blanks at end of text
+ FI
+ PER;
+ length of text := 0.
+
+new next character node:
+ x new node (character data, code (text SUB i), 1).
+
+END PROC sym;
+
+
+INT PROC character (SYM CONST sym):
+ IF x status (sym) = character data THEN
+ CONCR (x head (sym))
+ ELSE
+ error stop ("ist kein Charakter");
+ -1
+ FI
+END PROC character;
+
+
+BOOL PROC is character (SYM CONST sym):
+ x status (sym) = character data
+END PROC is character;
+
+
+SYM PROC sym character (INT CONST char):
+ x new node (character data, char MOD 256, 1)
+END PROC sym character;
+
+
+INT PROC int 1 (SYM CONST sym):
+ IF x status (sym) = int data THEN
+ CONCR (x head (sym))
+ ELSE
+ error stop ("ist keine Zahl");
+ -1
+ FI
+END PROC int 1;
+
+
+INT PROC int 2 (SYM CONST sym):
+ IF x status (sym) = int data THEN
+ CONCR (x tail (sym))
+ ELSE
+ error stop ("ist keine Zahl");
+ -1
+ FI
+END PROC int 2;
+
+
+BOOL PROC is int pair (SYM CONST sym):
+ x status (sym) = int data
+END PROC is int pair;
+
+
+SYM PROC sym (INT CONST int 1, int 2):
+ x new node (int data, int 1, int 2)
+END PROC sym;
+
+
+(********************* internal error routine *****************************)
+
+
+PROC x lisp error (TEXT CONST error message):
+ error stop (""13"LISP SYSTEM FEHLER: " + error message )
+END PROC x lisp error;
+
+
+END PACKET lisp heap and oblist management;
+
+
+
+PACKET name (* Autor: J.Durchholz *)
+ (* Datum: 15.06.1982 *)
+ DEFINES (* Version 1.1.1 *)
+
+ name:
+
+TEXT PROC name (SYM CONST sym):
+ IF is named atom (sym) THEN
+ text (property (sym, pname))
+ ELSE
+ ""15"IST_KEIN_ATOM"14""
+ FI
+END PROC name;
+
+
+END PACKET name;
+
+
+
+PACKET lisp storage info (* Autor: J.Durchholz *)
+ (* Datum: 23.08.1982 *)
+ DEFINES (* Version 1.1.1 *)
+
+ lisp storage info:
+
+
+PROC lisp storage info:
+ INT VAR size, used;
+ lisp storage (size, used);
+ out (""13""10" ");
+ put (used);
+ put ("Knoten von");
+ put (size);
+ put line ("Knoten des LISP-Heaps sind belegt!")
+END PROC lisp storage info;
+
+
+END PACKET lisp storage info;
diff --git a/lang/lisp/1.7.2/src/lisp.2 b/lang/lisp/1.7.2/src/lisp.2 new file mode 100644 index 0000000..956aa5c --- /dev/null +++ b/lang/lisp/1.7.2/src/lisp.2 @@ -0,0 +1,550 @@ +PACKET character buffer (* Autor : J.Durchholz *)
+ (* Datum : 09.05.1984 *)
+ DEFINES (* Version 1.7.2 *)
+ (* 21.2.83. hey 293, 450,97,361 *)
+ get char,
+ line nr,
+ init char buffer:
+
+
+TEXT VAR buffer;
+INT VAR pointer,
+ line;
+
+
+INT PROC line nr:
+ line
+END PROC line nr;
+
+
+PROC init char buffer:
+ buffer := "";
+ pointer := 1;
+ line := 0;
+END PROC init char buffer;
+
+
+PROC get char (FILE VAR f, TEXT VAR char):
+ IF buffer empty THEN
+ try to find nonempty line and put it into buffer;
+ char := " ";
+ pointer := 1
+ ELSE
+ char := buffer SUB pointer;
+ pointer INCR 1
+ FI.
+
+buffer empty:
+ pointer > length (buffer).
+
+try to find nonempty line and put it into buffer:
+ REP
+ IF eof (f) THEN
+ char := "";
+ LEAVE get char
+ FI;
+ get line (f, buffer);
+ line INCR 1
+ UNTIL buffer <> "" PER.
+
+END PROC get char;
+
+
+END PACKET character buffer;
+
+
+
+
+PACKET lisp io (* Autor: J.Durchholz *)
+ (* Datum: 10.09.1982 *)
+ DEFINES (* Version 4.1.3 *)
+
+ put,
+ verbose lisp output,
+ get,
+ get all:
+
+
+BOOL VAR verbose :: FALSE;
+
+
+PROC verbose lisp output (BOOL CONST b):
+ verbose := b
+END PROC verbose lisp output;
+
+BOOL PROC verbose lisp output:
+ verbose
+END PROC verbose lisp output;
+
+
+PROC put (FILE VAR f, SYM CONST sym):
+ IF atom (sym) THEN
+ put atom
+ ELSE
+ put structure
+ FI.
+
+put atom:
+ IF is named atom (sym) THEN
+ put (f, name (sym))
+ ELIF is int pair (sym) THEN
+ put (f, int 1 (sym))
+ ELIF is text (sym) THEN
+ IF verbose THEN
+ TEXT VAR buffer :: text (sym);
+ change all (buffer, """", """""");
+ buffer CAT """";
+ put (f, """" + buffer)
+ ELSE
+ write (f, text (sym))
+ FI
+ ELIF is character (sym) THEN
+ IF verbose THEN
+ buffer := "'";
+ buffer CAT code (character (sym));
+ buffer CAT "'";
+ put (f, buffer)
+ ELSE
+ write (f, code (character (sym)))
+ FI
+ ELSE
+ put (f, ""15"UNBEKANNTER_ATOM_TYP"14"")
+ FI.
+
+put structure:
+ put (f, "(");
+ SYM VAR actual node := sym;
+ REP
+ put (f, head (actual node));
+ actual node := tail (actual node)
+ UNTIL atom (actual node) PER;
+ IF NOT null (actual node) THEN
+ put (f, ".");
+ put (f, actual node)
+ FI;
+ put (f, ")").
+
+END PROC put;
+
+
+PROC put (SYM CONST sym):
+ IF atom (sym) THEN
+ put atom
+ ELSE
+ put structure
+ FI.
+
+put atom:
+ IF is named atom (sym) THEN
+ put (name (sym))
+ ELIF is int pair (sym) THEN
+ put (int 1 (sym))
+ ELIF is text (sym) THEN
+ IF verbose THEN
+ TEXT VAR buffer :: text (sym);
+ change all (buffer, """", """""");
+ buffer CAT """";
+ put ("""" + buffer)
+ ELSE
+ write (text (sym))
+ FI
+ ELIF is character (sym) THEN
+ IF verbose THEN
+ buffer := "'";
+ buffer CAT code (character (sym));
+ buffer CAT "'";
+ put (buffer)
+ ELSE
+ out (code (character (sym)))
+ FI
+ ELSE
+ put (""15"UNBEKANNTER_ATOM_TYP"14"")
+ FI.
+
+put structure:
+ put ("(");
+ SYM VAR actual node := sym;
+ REP
+ put (head (actual node));
+ actual node := tail (actual node)
+ UNTIL atom (actual node) PER;
+ IF NOT null (actual node) THEN
+ put (".");
+ put (actual node)
+ FI;
+ put (")").
+
+END PROC put;
+
+
+PROC get (FILE VAR f, SYM VAR s):
+ initialize scanner (f);
+ IF NOT get s expression (s) THEN
+ error ("LISP-Ausdruck erwartet")
+ FI;
+ scanner postprocessing (f)
+END PROC get;
+
+
+(**************************** parser for 'get' ****************************)
+
+
+LET end of file type = 0,
+ name type = 1,
+ text type = 2,
+ character type = 3,
+ int type = 4,
+ other char type = 5;
+
+
+BOOL PROC get s expression (SYM VAR s):
+ (* The boolean result indicates wether the error has not occurred that *)
+ (* 'get next symbol' was called, but then the symbol was not expected *)
+ (* and thus could not be processed. *)
+ get next symbol;
+ SELECT symbol type OF
+ CASE end of file type: FALSE
+ CASE name type: s := new atom (symbol); TRUE
+ CASE text type: s := sym (symbol); TRUE
+ CASE character type: s := sym character (code (symbol)); TRUE
+ CASE int type: s := sym (int (symbol), -1); TRUE
+ CASE other char type: get structure
+ OTHERWISE error ("EINLESEFEHLER: unbekannter Symboltyp: " +
+ text (symbol type)); TRUE
+ END SELECT.
+
+get structure:
+ IF symbol <> "(" THEN
+ FALSE
+ ELSE
+ get list;
+ IF symbol type <> other char type OR symbol <> ")" THEN
+ error (">> ) << erwartet");
+ FALSE
+ ELSE
+ TRUE
+ FI
+ FI.
+
+get list:
+ SYM VAR father, son;
+ IF get s expression (son) THEN
+ get list elements;
+ ELSE
+ s := nil
+ FI.
+
+get list elements:
+ father := cons (son, nil);
+ s := father;
+ WHILE get s expression (son) REP
+ set tail (father, cons (son, nil));
+ father := tail (father)
+ PER;
+ IF symbol type = other char type AND symbol = "." THEN
+ IF get s expression (son) THEN
+ set tail (father, son);
+ get next symbol
+ ELSE
+ error ("LISP-Ausdruck nach dem Punkt erwartet")
+ FI
+ FI.
+
+END PROC get s expression;
+
+
+(********************* scanner for 'get x espression' *********************)
+
+
+FILE VAR infile;
+
+
+PROC initialize scanner (FILE CONST f):
+ infile := f;
+ no input errors := TRUE;
+ init char buffer;
+ get char (infile, actual char)
+END PROC initialize scanner;
+
+
+PROC scanner postprocessing (FILE VAR f):
+ f := infile
+END PROC scanner postprocessing;
+
+
+TEXT VAR symbol; INT VAR symbol type;
+
+
+PROC get next symbol:
+ skip blanks;
+ IF actual char = "" THEN
+ symbol := "DATEIENDE";
+ symbol type := end of file type
+ ELIF is letter THEN
+ get name
+ ELIF is digit or sign THEN
+ get integer
+ ELIF is double quote THEN
+ get text
+ ELIF is single quote THEN
+ get character
+ ELSE
+ get other char
+ FI .
+
+is letter:
+ IF "a" <= actual char AND actual char <= "z" THEN
+ actual char := code (code (actual char) - code ("a") + code ("A"));
+ TRUE
+ ELSE
+ "@" <= actual char AND actual char <= "Z"
+ FI.
+
+get name:
+ symbol type := name type;
+ symbol := actual char;
+ REP
+ get char (infile, actual char);
+ IF is neither letter nor digit THEN
+ LEAVE get name
+ FI;
+ symbol CAT actual char
+ PER.
+
+is neither letter nor digit:
+ NOT (is letter OR is digit OR is underscore).
+
+is digit:
+ "0" <= actual char AND actual char <= "9".
+
+is underscore:
+ actual char = "_".
+
+is digit or sign:
+ is digit OR actual char = "+" OR actual char = "-".
+
+get integer:
+ symbol type := int type;
+ IF actual char = "+" THEN
+ get char (infile, actual char);
+ skip blanks;
+ symbol := actual char
+ ELIF actual char = "-" THEN
+ symbol := "-";
+ get char (infile, actual char);
+ skip blanks;
+ symbol CAT actual char
+ ELSE
+ symbol := actual char
+ FI;
+ REP
+ get char (infile, actual char);
+ IF NOT is digit THEN
+ LEAVE get integer
+ FI;
+ symbol CAT actual char
+ PER.
+
+is double quote:
+ actual char = """".
+
+get text:
+ symbol := "";
+ symbol type := text type;
+ REP
+ get char (infile, actual char);
+ IF is double quote THEN
+ get char (infile, actual char);
+ IF NOT is double quote THEN LEAVE get text
+ FI
+ ELIF actual char = "" THEN LEAVE get text (*hey*)
+ FI;
+ symbol CAT actual char
+ PER.
+
+is single quote:
+ actual char = "'".
+
+get character:
+ symbol type := character type;
+ get char (infile, symbol);
+ get char (infile, actual char);
+ IF actual char <> "'" THEN
+ error (">> ' << erwartet")
+ ELSE
+ get char (infile, actual char)
+ FI.
+
+get other char:
+ symbol type := other char type;
+ symbol := actual char;
+ get char (infile, actual char).
+
+END PROC get next symbol;
+
+
+TEXT VAR actual char;
+
+
+PROC skip blanks:
+ INT VAR comment depth :: 0;
+ WHILE is comment OR actual char = " " REP
+ get char (infile, actual char)
+ PER.
+
+is comment:
+ IF actual char = "{" THEN
+ comment depth INCR 1;
+ TRUE
+ ELIF actual char = "}" THEN
+ IF comment depth = 0 THEN
+ error (">> { << fehlt")
+ ELSE
+ comment depth DECR 1
+ FI;
+ TRUE
+ ELSE
+ IF comment depth > 0 THEN
+ IF actual char = "" THEN
+ error ("DATEIENDE im Kommentar");
+ FALSE
+ ELSE
+ TRUE
+ FI
+ ELSE
+ FALSE
+ FI
+ FI.
+
+END PROC skip blanks;
+
+
+BOOL VAR no input errors;
+FILE VAR errors;
+
+
+PROC error (TEXT CONST error message):
+ out ("FEHLER in Zeile ");
+ out (text (line nr));
+ out (" bei >> ");
+ out (symbol);
+ out (" << : ");
+ out (error message);
+ line;
+ IF no input errors THEN
+ no input errors := FALSE;
+ errors := notefile; modify(errors);
+ headline (errors, "Einlesefehler"); output(errors)
+ FI;
+ write (errors, "FEHLER in Zeile ");
+ write (errors, text (line nr));
+ write (errors, " bei >> ");
+ write (errors, symbol);
+ write (errors, " << : ");
+ write (errors, error message);
+ line (errors)
+END PROC error;
+
+
+PROC get (SYM VAR sym): (*hey*)
+ disable stop;
+ FILE VAR in :: sequential file (modify, "LISP INPUT"),
+ out :: notefile; modify (out);
+ headline (out,"LISP OUTPUT");
+ headline (in, "LISP INPUT");
+ editable (out,in); output(out);
+ input (in);
+ get (in, sym);
+ WHILE NOT no input errors AND NOT is error REP
+ modify (errors);
+ headline (errors, " LISP-Fehlermeldungen");
+ headline (in, " Bitte KORREKTEN LISP-Ausdruck");
+ editable (errors, in);
+ headline (errors, "notebook");
+ output (errors);
+ input (in);
+ get (in, sym)
+ PER;
+END PROC get;
+
+
+PROC editable (FILE VAR a,b): (*hey*)
+ enable stop; edit (a,b); to line (a,lines(a)); remove(a,lines(a))
+END PROC editable;
+
+PROC edit (FILE VAR a,b):
+ open editor (1, b, write acc, 1, 1, 79, 24);
+ open editor (2, a, write acc, 1,13, 79, 12);
+ edit (1)
+ END PROC edit;
+
+LET write acc = TRUE;
+
+PROC get all (FILE VAR f, SYM VAR sym):
+ get (f, sym);
+ skip blanks;
+ IF NOT eof (infile) THEN
+ error ("Hinter dem letzten Symbol des LISP-Ausdruck stehen noch Zeichen")
+ FI
+END PROC get all;
+
+
+END PACKET lisp io;
+
+
+
+PACKET lisp integer (* Autor: J.Durchholz *)
+ (* Datum: 30.08.1982 *)
+ DEFINES (* Version 1.1.2 *)
+
+ sum,
+ difference,
+ product,
+ quotient,
+ remainder:
+
+SYM PROC sum (SYM CONST summand list):
+ INT VAR result := 0;
+ SYM VAR list rest := summand list;
+ WHILE NOT atom (list rest) REP
+ result INCR int 1 (head (list rest));
+ list rest := tail (list rest)
+ PER;
+ IF NOT null (list rest) THEN
+ error stop ("Summandenliste endet falsch")
+ FI ;
+ sym (result, -1)
+END PROC sum;
+
+
+SYM PROC difference (SYM CONST minuend, subtrahend):
+ sym (int 1 (minuend) - int 1 (subtrahend), -1)
+END PROC difference;
+
+
+SYM PROC product (SYM CONST factor list):
+ INT VAR result := 1;
+ SYM VAR list rest := factor list;
+ WHILE NOT atom (list rest) REP
+ result := result * int 1 (head (list rest));
+ list rest := tail (list rest)
+ PER;
+ IF NOT null (list rest) THEN
+ error stop ("Faktorenliste endet falsch")
+ FI;
+ sym (result, -1)
+END PROC product;
+
+
+SYM PROC quotient (SYM CONST dividend, divisor):
+ sym (int 1 (dividend) DIV int 1 (divisor), -1)
+END PROC quotient;
+
+
+SYM PROC remainder(SYM CONST dividend, divisor):
+ sym (int 1 (dividend) MOD int 1 (divisor), -1)
+END PROC remainder;
+
+
+END PACKET lisp integer;
+
diff --git a/lang/lisp/1.7.2/src/lisp.3 b/lang/lisp/1.7.2/src/lisp.3 new file mode 100644 index 0000000..dfde6db --- /dev/null +++ b/lang/lisp/1.7.2/src/lisp.3 @@ -0,0 +1,142 @@ +PACKET lisp (* Autor: J.Durchholz , P. Heyderhoff *)
+ (* Datum: 09.05.1984 *)
+ DEFINES (* Version 1.7.2 *)
+
+ start lisp system,
+ lisp heap,
+ insert lisp,
+ run lisp,
+ run lisp again,
+ lisp:
+
+SYM VAR run again pointer :: nil;
+DATASPACE VAR insert heap :: nil space;
+
+PROC start lisp system (DATASPACE CONST heap):
+ enable stop;
+ initialize lisp system (heap);
+ forget (insert heap);
+ insert heap := heap
+END PROC start lisp system;
+
+
+PROC start lisp system (DATASPACE CONST heap, FILE VAR f):
+ start lisp system (heap);
+ input (f);
+ WHILE NOT eof (f) REP
+ TEXT VAR name;
+ get (f, name);
+ SYM CONST s :: new atom (name);
+ get (f, name);
+ SYM CONST property name :: new atom (name);
+ IF NOT null (property name) THEN
+ SYM VAR property;
+ get (f, property);
+ add property (s, property name, property)
+ FI;
+ PER
+END PROC start lisp system;
+
+
+PROC start lisp system (FILE VAR f):
+ create lisp system (f, insert heap)
+END PROC start lisp system;
+
+
+DATASPACE PROC lisp heap:
+ insert heap
+END PROC lisp heap;
+
+
+DATASPACE VAR run heap :: nil space;
+
+
+PROC insert lisp:
+ insert lisp (last param)
+END PROC insert lisp;
+
+
+PROC insert lisp (TEXT CONST file name):
+ interpret (insert heap, file name)
+END PROC insert lisp;
+
+
+PROC run lisp:
+ run lisp (last param)
+END PROC run lisp;
+
+
+PROC run lisp (TEXT CONST file name):
+ forget (run heap);
+ run heap := insert heap;
+ interpret (run heap, file name)
+END PROC run lisp;
+
+
+DATASPACE VAR do heap :: nil space,
+ do file :: nil space;
+
+
+
+PROC interpret (DATASPACE CONST heap, TEXT CONST file name):
+ enable stop;
+ FILE VAR f :: sequential file (input, file name);
+ interpret (heap, f)
+END PROC interpret;
+
+
+PROC interpret (DATASPACE CONST heap, FILE VAR f):
+ initialize lisp system (heap);
+ get (f, run again pointer);
+ add property (new atom ("program"), new atom ("APVAL"), run again pointer);
+ put (evalquote (run again pointer))
+END PROC interpret;
+
+PROC run lisp again:
+ put (evalquote (run again pointer))
+END PROC run lisp again;
+
+
+PROC get ausdruck:
+ enable stop; get (ausdruck)
+END PROC get ausdruck;
+
+SYM VAR ausdruck;
+
+PROC lisp:
+
+(* HAUPT TESTPROGRAMM FUER LISP Heyderhoff 25.1.83 *)
+IF NOT exists ("LISP HEAP") THEN
+ FILE VAR bootstrap :: sequential file (input, "lisp.bootstrap");
+ create lisp system (bootstrap, new ("LISP HEAP"));
+ verbose lisp output (TRUE);
+FI;
+FILE VAR out :: notefile; output (out);
+SYM VAR work;
+command dialogue(FALSE); forget ("LISP INPUT"); command dialogue(TRUE);
+(* bildlaenge(23); *) (* EUMEL 1.65 *)
+disable stop;
+REP
+ get (ausdruck);
+ IF is error THEN
+ handle error
+ ELSE
+ output (out);
+ work := evalquote (ausdruck);
+ IF is error THEN handle error
+ ELSE put (out, work)
+ FI
+ FI
+PER .
+
+handle error:
+ IF text (error message, 18) = "halt from terminal" THEN
+ enable stop
+ ELSE
+ put (out, error message);
+ put ( error message); pause(20);
+ clear error;
+ FI .
+END PROC lisp;
+END PACKET lisp;
+
diff --git a/lang/lisp/1.7.2/src/lisp.4 b/lang/lisp/1.7.2/src/lisp.4 new file mode 100644 index 0000000..f36706d --- /dev/null +++ b/lang/lisp/1.7.2/src/lisp.4 @@ -0,0 +1,766 @@ +PACKET lisp heap maintenance (* Autor: J.Durchholz *)
+ (* Datum: 09.05.1984 *)
+ DEFINES (* Version 1.7.2 *)
+ (* Testhilfe *)
+ create lisp system, (* hey, 02.3.83 : 121,334,542,732 *)
+ dump oblist:
+
+
+PROC create lisp system (FILE VAR f, DATASPACE CONST new heap):
+ initialize lisp system (new heap);
+ input (f);
+ WHILE NOT eof (f) REP
+ TEXT VAR name;
+ get (f, name);
+ SYM CONST s :: new atom (name);
+ get (f, name);
+ SYM CONST property name :: new atom (name);
+ IF NOT null (property name) THEN
+ SYM VAR property;
+ get (f, property);
+ add property (s, property name, property)
+ FI
+ PER
+END PROC create lisp system;
+
+
+PROC dump oblist (FILE VAR f):
+ begin oblist dump;
+ REP
+ SYM CONST actual atom :: next atom;
+ put line (f, name (actual atom));
+ dump property list
+ UNTIL null (actual atom) PER.
+
+dump property list:
+ begin property list dump (actual atom);
+ REP
+ SYM VAR id, value;
+ next property (id, value);
+ write (f, " ");
+ write (f, name (id));
+ write (f, " ");
+ write (f, name (value));
+ line (f)
+ UNTIL null (id) AND null (value) PER.
+
+END PROC dump oblist;
+
+
+PROC dump oblist:
+ begin oblist dump;
+ REP
+ SYM CONST actual atom :: next atom;
+ put line (name (actual atom));
+ dump property list
+ UNTIL null (actual atom) PER.
+
+dump property list:
+ begin property list dump (actual atom);
+ REP
+ SYM VAR id, value;
+ next property (id, value);
+ out (" ");
+ out (name (id));
+ out (" ");
+ put line (name (value));
+ UNTIL null (id) AND null (value) PER.
+
+END PROC dump oblist;
+
+
+END PACKET lisp heap maintenance;
+
+
+
+PACKET lisp interpreter (* Autor: J.Durchholz *)
+ (* Datum: 27.12.1982 *)
+ DEFINES (* Version 3.1.7 *)
+ evalquote,
+ apply,
+ eval,
+ try:
+
+
+(* SYM-objects used by the interpreter. They all point to constant structure
+ within the heap. As their address may change during garbage collection,
+ it must be possible to correct the references to them made by the
+ SYM-objects. That is the reason why they are declared VAR instead of CONST*)
+SYM VAR lambda constant,
+ label constant,
+ quote constant,
+ function constant,
+ indefinite constant,
+ apval constant,
+ true constant,
+ false constant;
+
+SYM VAR errors;
+BOOL VAR trace :: FALSE;
+
+PROC initialize constants:
+ lambda constant := new atom ("LAMBDA");
+ label constant := new atom ("LABEL");
+ quote constant := new atom ("QUOTE");
+ function constant := new atom ("FUNCTION");
+ indefinite constant := new atom ("INDEFINITE");
+ apval constant := new atom ("APVAL");
+ true constant := new atom ("T");
+ false constant := new atom ("F");
+ errors := new atom ("ERRORS")
+END PROC initialize constants;
+
+
+SYM PROC evalquote (SYM CONST expr): (*hey*)
+ enable stop;
+ initialize constants;
+ x apply ( head (expr), quote (tail (expr)), nil )
+END PROC evalquote;
+
+
+SYM PROC quote (SYM CONST x):
+ IF eq (x,nil) THEN nil
+ ELSE set head (x, new head); set tail (x, quote (tail(x))); x
+ FI .
+new head:
+ cons (quote constant, cons (head(x), nil) )
+END PROC quote;
+
+
+SYM PROC apply (SYM CONST function, argument list, alist):
+ enable stop;
+ initialize constants;
+ x apply (function, argument list, alist)
+END PROC apply;
+
+
+SYM PROC x apply (SYM CONST function, argument list, alist):
+ IF trace THEN line;
+ put ("a p p l y :"); put (function); line;
+ put ("arguments :"); put (argument list); line;
+ FI;
+ SYM VAR new alist;
+ initialize for alist insertion;
+ reduce actual fn to lambda expression;
+ insert parameter evaluated argument pairs in reversed order in new alist;
+ function body evaluation.
+
+reduce actual fn to lambda expression:
+ SYM VAR actual fn :: function;
+ REP
+ IF is named atom (actual fn) THEN
+ get function from property list of actual fn
+ or from functional alist entry
+ ELIF atom (actual fn) THEN
+ error stop ("Eine Funktion darf kein unbenanntes Atom sein")
+ ELSE
+ IF eq (head (actual fn), lambda constant) THEN
+ LEAVE reduce actual fn to lambda expression
+ ELIF eq (head (actual fn), label constant) THEN
+ get function from label expression and update alist
+ ELSE
+ error stop ("Funktion ist weder Atom noch LAMBDA-/LABEL-Ausdruck")
+ FI
+ FI
+ PER.
+
+get function from property list of actual fn or from functional alist entry:
+ IF property exists (actual fn, function constant) THEN
+ get function from property list of actual fn
+ ELSE
+ get function from functional alist entry
+ FI.
+
+get function from property list of actual fn:
+ actual fn := property (actual fn, function constant).
+
+get function from functional alist entry:
+ SYM VAR actual alist entry;
+ begin alist retrieval;
+ REP
+ IF end of alist THEN
+ error stop ("Die Funktion " + name (actual fn) +
+ " ist nicht definiert")
+ FI;
+ search for next functional alist entry;
+ UNTIL eq (head (actual functional alist entry), actual fn) PER;
+ actual fn := tail (actual functional alist entry).
+
+get function from label expression and update alist:
+ actual fn := tail (actual fn);
+ IF atom (actual fn) COR
+ (NOT atom (head (actual fn)) OR atom (tail (actual fn))) COR
+ NOT null (tail (tail (actual fn))) THEN
+ error stop ("Ungueltiger LABEL-Ausdruck")
+ FI;
+ SYM VAR new alist entry;
+ prepare new functional alist entry;
+ set head (new alist entry, head (actual fn));
+ actual fn := head (tail (actual fn));
+ set tail (new alist entry, actual fn).
+
+insert parameter evaluated argument pairs in reversed order in new alist:
+ actual fn := tail (actual fn);
+ IF atom (actual fn) THEN
+ error stop ("Ungueltiger LAMBDA-Ausdruck")
+ FI;
+ SYM VAR parameter list rest :: head (actual fn),
+ argument list rest :: argument list;
+ actual fn := tail (actual fn);
+ WHILE NOT null (parameter list rest) REP
+ add next parameter argument pair to alist
+ PER;
+ check wether no arguments are left over.
+
+add next parameter argument pair to alist:
+ IF atom (parameter list rest) THEN
+ error stop ("Parameterliste endet falsch")
+ FI;
+ SYM VAR param pointer :: head (parameter list rest);
+ parameter list rest := tail (parameter list rest);
+ IF is named atom (param pointer) AND NOT null (param pointer) THEN
+ add parameter evaluated argument pair to alist;
+ advance argument list rest
+ ELIF atom (param pointer) THEN
+ error stop ("Unbenannte Atome und NIL koennen nicht Parameter sein")
+ ELSE
+ IF eq (head (param pointer), indefinite constant) THEN
+ check wether is last param;
+ advance param pointer;
+ IF eq (head (param pointer), quote constant) THEN
+ advance param pointer;
+ move param pointer to parameter;
+ add parameter indefinite quoted argument pair to alist
+ ELSE
+ move param pointer to parameter;
+ add parameter indefinite evaluated argument pair to alist
+ FI;
+ argument list rest := nil
+ ELIF eq (head (param pointer), quote constant) THEN
+ advance param pointer;
+ move param pointer to parameter;
+ add parameter quoted argument pair to alist;
+ advance argument list rest
+ ELIF eq (head (param pointer), function constant) THEN
+ advance param pointer;
+ move param pointer to parameter;
+ add parameter functional argument pair to alist;
+ advance argument list rest
+ ELSE
+ error stop ("Ungueltiger Parameter")
+ FI
+ FI.
+
+advance param pointer:
+ param pointer := tail (param pointer);
+ IF atom (param pointer) THEN
+ error stop ("Ungueltiger Parameter")
+ FI.
+
+move param pointer to parameter:
+ IF NOT null (tail (param pointer)) THEN
+ error stop ("Ungueltiger Parameter")
+ FI;
+ param pointer := head (param pointer);
+ IF NOT atom (param pointer) OR null (param pointer) THEN
+ error stop ("Unbenannte Atome und NIL koennen nicht Parameter sein")
+ FI.
+
+advance argument list rest:
+ argument list rest := tail (argument list rest).
+
+add parameter evaluated argument pair to alist:
+ prepare new alist entry;
+ set head (new alist entry, param pointer);
+ set tail (new alist entry, x eval (actual argument, alist)).
+
+check wether is last param:
+ IF NOT null (parameter list rest) THEN
+ error stop ("Ein INDEFINITE-Parameter muss der letzte sein")
+ FI.
+
+add parameter indefinite quoted argument pair to alist:
+ prepare new alist entry;
+ set head (new alist entry, param pointer);
+ set tail (new alist entry, argument list rest);
+ WHILE NOT atom (argument list rest) REP
+ argument list rest := tail (argument list rest)
+ PER;
+ IF NOT null (argument list rest) THEN
+ error stop ("Argumentliste endet falsch")
+ FI.
+
+add parameter indefinite evaluated argument pair to alist:
+ prepare new alist entry;
+ set head (new alist entry, param pointer);
+ last evaluated argument := new alist entry;
+ WHILE NOT atom (argument list rest) REP
+ set tail (last evaluated argument,
+ cons (x eval (head (argument list rest), alist), nil));
+ last evaluated argument := tail (last evaluated argument);
+ advance argument list rest
+ PER;
+ IF NOT null (argument list rest) THEN
+ error stop ("Argumentliste endet falsch")
+ FI.
+
+last evaluated argument:
+ param pointer.
+(* The value of param pointer is not used further, so the *)
+(* variable can be "reused" in this manner. *)
+
+add parameter quoted argument pair to alist:
+ prepare new alist entry;
+ set head (new alist entry, param pointer);
+ set tail (new alist entry, actual argument).
+
+add parameter functional argument pair to alist:
+ prepare new functional alist entry;
+ set head (new alist entry, param pointer);
+ set tail (new alist entry, actual argument).
+
+actual argument:
+ IF atom (argument list rest) THEN
+ IF null (argument list rest) THEN
+ error stop ("Zuwenig Argumente")
+ ELSE
+ error stop ("Argumentliste endet falsch")
+ FI
+ FI;
+ head (argument list rest).
+
+check wether no arguments are left over:
+ IF NOT null (argument list rest) THEN
+ error stop ("Zuviele Argumente")
+ FI.
+
+function body evaluation:
+ IF is int pair (actual fn) THEN
+ predefined function evaluation
+ ELIF atom (actual fn) COR NOT null (tail (actual fn)) THEN
+ error stop ("Ungueltiger LAMBDA-Ausdruck"); nil
+ ELSE
+ x eval (head (actual fn), new alist)
+ FI.
+
+predefined function evaluation:
+ SELECT int 1 (actual fn) OF
+ CASE 0: call eval cond
+ CASE 1: call begin oblist dump
+ CASE 2: call next atom
+ CASE 3: call add property
+ CASE 4: call alter property
+ CASE 5: call delete property
+ CASE 6: call property exists
+ CASE 7: call property
+ CASE 8: call add flag
+ CASE 9: call flag
+ CASE 10: call delete flag
+ CASE 11: call begin property list dump
+ CASE 12: call next property
+ CASE 13: call apply
+ CASE 14: call eval
+ CASE 15: call try
+ CASE 16: give association list
+ CASE 17: call error stop
+ CASE 18: call head
+ CASE 19: call set head
+ CASE 20: call tail
+ CASE 21: call set tail
+ CASE 22: call cons
+ CASE 23: call eq
+ CASE 24: call get sym
+ CASE 25: call put sym
+ CASE 26: call null
+ CASE 27: call is atom
+ CASE 28: call is named atom
+ CASE 29: call get named atom
+ CASE 30: call put named atom
+ CASE 31: call is text
+ CASE 32: call get text
+ CASE 33: call put text
+ CASE 34: call is character
+ CASE 35: call get character
+ CASE 36: call put character
+ CASE 37: call is int
+ CASE 38: call get int
+ CASE 39: call put int
+ CASE 40: call sum
+ CASE 41: call difference
+ CASE 42: call product
+ CASE 43: call quotient
+ CASE 44: call remainder
+ CASE 45: call equal
+ CASE 46: call trace
+ CASE 47: call define
+ CASE 48: call set
+ OTHERWISE error stop("Es gibt (noch) keine LISP-Funktion mit der Nummer"
+ + text (int 1 (actual fn)) ); nil
+ END SELECT.
+
+call eval cond:
+ x eval condition (arg 1, alist).
+
+call begin oblist dump:
+ begin oblist dump; nil.
+
+call next atom:
+ next atom.
+
+call add property:
+ add property (arg 3, arg 2, arg 1); arg 1.
+
+call alter property:
+ alter property (arg 3, arg 2, arg 1); arg 1.
+
+call delete property:
+ delete property (arg 2, arg 1); nil.
+
+call property exists:
+ IF property exists(arg 2,arg 1) THEN true constant ELSE false constant FI.
+
+call property:
+ property (arg 2, arg 1).
+
+call add flag:
+ add flag (arg 2, arg 1); nil.
+
+call flag:
+ IF flag (arg 2, arg 1) THEN true constant ELSE false constant FI.
+
+call delete flag:
+ delete flag (arg 2, arg 1); nil.
+
+call begin property list dump:
+ begin property list dump (arg 1); nil.
+
+call next property:
+ SYM VAR s1, s2; next property (s1, s2); cons (s1, s2).
+
+call apply:
+ x apply (arg 3, arg 2, arg 1).
+
+call eval:
+ x eval (arg 2, arg 1).
+
+call try:
+ x try (arg 4, arg 3, arg 2, arg 1).
+
+give association list:
+ alist.
+
+call error stop:
+ error stop (text (arg 1)); nil.
+
+call head:
+ head (arg 1).
+
+call set head:
+ set head (arg 2, arg 1); arg 2.
+
+call tail:
+ tail (arg 1).
+
+call set tail:
+ set tail (arg 2, arg 1); arg 2.
+
+call cons:
+ cons (arg 2, arg 1).
+
+call eq:
+ IF eq (arg 2, arg 1) THEN true constant ELSE false constant FI.
+
+call get sym:
+ get (s1); s1.
+
+call put sym:
+ put (arg 1); arg 1.
+
+call null:
+ IF null (arg 1) THEN true constant ELSE false constant FI.
+
+call is atom:
+ IF atom (arg 1) THEN true constant ELSE false constant FI.
+
+call is named atom:
+ IF is named atom (arg 1) THEN true constant ELSE false constant FI.
+
+call get named atom:
+ TEXT VAR t; get (t); new atom (t).
+
+call put named atom:
+ put (name (arg 1)); arg 1.
+
+call is text:
+ IF is text (arg 1) THEN true constant ELSE false constant FI.
+
+call get text:
+ get (t); sym (t).
+
+call put text:
+ put (text (arg 1)); arg 1.
+
+call is character:
+ IF is character (arg 1) THEN true constant ELSE false constant FI.
+
+call get character:
+ inchar (t); sym character (code (t)).
+
+call put character:
+ out (code (character (arg 1))); arg 1.
+
+call is int:
+ IF is int pair (arg 1) THEN true constant ELSE false constant FI.
+
+call get int:
+ INT VAR i; get (i); sym (i, -1).
+
+call put int:
+ put (int 1 (arg 1)); arg 1.
+
+call sum:
+ sum (arg 1).
+
+call difference:
+ difference (arg 2, arg 1).
+
+call product:
+ product (arg 1).
+
+call quotient:
+ quotient (arg 2, arg 1).
+
+call remainder:
+ remainder(arg 2, arg 1).
+
+call equal:
+ IF equal (arg 2, arg 1) THEN true constant ELSE false constant FI.
+
+call trace:
+ trace := NOT trace;
+ IF trace THEN true constant ELSE false constant FI .
+
+call define: (*hey*)
+ define (arg 1) .
+
+call set: (*hey*)
+ add property (new atom ( name (arg 2)), apval constant, arg 1); arg 1 .
+
+arg 1:
+ tail (head (new alist)).
+
+arg 2:
+ tail (head (tail (new alist))).
+
+arg 3:
+ tail (head (tail (tail (new alist)))).
+
+arg 4:
+ tail (head (tail (tail (tail (new alist))))).
+
+END PROC x apply;
+
+SYM PROC define (SYM CONST x): (*hey*)
+ IF eq (x, nil) THEN nil
+ ELSE add property (new atom (name (head (head (x)))),
+ function constant, tail (head (x)) );
+ cons (head (head (x)), define (tail (x)) )
+ FI .
+END PROC define;
+
+SYM VAR old alist :: nil;
+
+SYM PROC eval (SYM CONST expression, alist):
+ enable stop;
+ initialize constants;
+ x eval (expression, alist)
+END PROC eval;
+
+
+SYM PROC x eval (SYM CONST expression, alist): (*hey*)
+ IF trace THEN line;
+ put ("e v a l :"); put (expression); line;
+ IF NOT equal (alist, old alist) THEN
+ put ("bindings :"); old alist := alist; put (alist); line FI
+ FI;
+ IF atom (expression) THEN
+ IF is named atom (expression) THEN
+ value from property list of expression or from alist entry
+ ELSE
+ expression
+ FI
+ ELSE
+ x apply (head (expression), tail (expression), alist)
+ FI.
+
+value from property list of expression or from alist entry:
+ IF property exists (expression, apval constant) THEN
+ value from property list of expression
+ ELSE
+ value from alist entry
+ FI.
+
+value from property list of expression:
+ property (expression, apval constant).
+
+value from alist entry:
+ SYM VAR actual alist entry;
+ begin alist retrieval;
+ REP
+ IF end of alist THEN
+ error stop ("Das Atom " + name (expression) + " hat keinen Wert")
+ FI;
+ search for next alist entry
+ UNTIL eq (head (actual alist entry), expression) PER;
+ tail (actual alist entry).
+
+END PROC x eval;
+
+
+SYM PROC try (SYM CONST expression list, alist,
+ error output, break possible):
+ enable stop;
+ initialize constants;
+ x try (expression list, alist, error output, break possible)
+END PROC try;
+
+
+SYM PROC x try (SYM CONST expression list, alist,
+ error output, break possible):
+ BOOL CONST output :: bool (error output),
+ halt enabled :: bool (break possible);
+ SYM VAR expr list rest :: expression list;
+ REP
+ IF null (expr list rest) THEN
+ LEAVE x try WITH nil
+ ELIF atom (expr list rest) THEN
+ error stop ("Ausdrucksliste fuer 'try' endet falsch")
+ ELSE
+ try evaluation of actual expression
+ FI;
+ expr list rest := tail (expr list rest)
+ PER;
+ nil.
+
+try evaluation of actual expression:
+ disable stop;
+ SYM VAR result :: x eval (head (expr list rest), alist);
+ IF is error THEN
+ IF error message = "halt from terminal" AND halt enabled THEN
+ enable stop
+ ELIF output THEN
+ put error
+ FI;
+ add property (errors, apval constant, sym (error message));
+ clear error
+ ELSE
+ LEAVE x try WITH result
+ FI;
+ enable stop.
+
+END PROC x try;
+
+
+SYM PROC x eval condition (SYM CONST pair list, alist):
+ enable stop;
+ SYM VAR cond pair list rest :: pair list;
+ REP
+ IF atom (cond pair list rest) THEN
+ error stop ("Keine 'T'-Bedingung in bedingtem Ausdruck gefunden")
+ FI;
+ check wether is correct pair;
+ IF true condition found THEN
+ LEAVE x eval condition WITH x eval (head (tail (actual pair)), alist)
+ FI;
+ cond pair list rest := tail (cond pair list rest)
+ PER;
+ nil.
+
+check wether is correct pair:
+ IF atom (actual pair) COR
+ atom (tail (actual pair)) COR
+ NOT null (tail (tail (actual pair))) THEN
+ error stop ("Ungueltiges Paar im bedingten Ausdruck")
+ FI.
+
+true condition found:
+ bool (x eval (head (actual pair), alist)).
+
+actual pair:
+ head (cond pair list rest).
+
+END PROC x eval condition;
+
+
+BOOL PROC bool (SYM CONST sym):
+ IF eq (sym, true constant) THEN
+ TRUE
+ ELIF eq (sym, false constant) THEN
+ FALSE
+ ELSE
+ error stop ("'T' oder 'F' erwartet"); TRUE
+ FI
+END PROC bool;
+
+
+(******* a-list handling refinements used in 'x apply' and 'x eval' *******)
+
+(* declared within 'x apply' and 'x eval': 'actual alist entry' *)
+
+.
+
+initialize for alist insertion:
+ new alist := alist.
+
+begin alist retrieval:
+ SYM VAR actual alist pos :: alist.
+
+search for next alist entry:
+ WHILE NOT end of alist REP
+ IF atom (actual alist pos) THEN
+ error stop ("Bindeliste endet falsch")
+ FI;
+ actual alist entry := head (actual alist pos);
+ actual alist pos := tail (actual alist pos);
+ UNTIL is non functional alist entry PER.
+
+is non functional alist entry:
+ NOT is functional alist entry.
+
+search for next functional alist entry:
+ WHILE NOT end of alist REP
+ IF atom (actual alist pos) THEN
+ error stop ("Bindeliste endet falsch")
+ FI;
+ actual alist entry := head (actual alist pos);
+ actual alist pos := tail (actual alist pos);
+ UNTIL is functional alist entry PER;
+ actual alist entry := tail (actual alist entry).
+
+is functional alist entry:
+ check wether is alist entry;
+ null (head (actual alist entry)).
+
+check wether is alist entry:
+ IF atom (actual alist entry) THEN
+ error stop ("Bindelisteneintrag ist kein Paar")
+ FI.
+
+end of alist:
+ null (actual alist pos).
+
+actual functional alist entry:
+ actual alist entry.
+
+prepare new alist entry:
+ new alist := cons (cons (nil, nil), new alist);
+ new alist entry := head (new alist).
+
+prepare new functional alist entry:
+ new alist := cons (cons (nil, cons (nil, nil)), new alist);
+ new alist entry := tail (head (new alist)).
+
+
+END PACKET lisp interpreter;
+
+
diff --git a/lang/lisp/1.7.2/src/lisp.bootstrap b/lang/lisp/1.7.2/src/lisp.bootstrap new file mode 100644 index 0000000..f28aae8 --- /dev/null +++ b/lang/lisp/1.7.2/src/lisp.bootstrap @@ -0,0 +1,117 @@ +NIL APVAL
+NIL
+T APVAL
+T
+F APVAL
+F
+COND FUNCTION
+(LAMBDA ((INDEFINITE QUOTE X)) . 0)
+BEGINOBLISTDUMP FUNCTION
+(LAMBDA () . 1)
+NEXTATOM FUNCTION
+(LAMBDA () . 2)
+ADDPROPERTY FUNCTION
+(LAMBDA (X X X) . 3)
+ALTERPROPERTY FUNCTION
+(LAMBDA (X X X) . 4)
+DELETEPROPERTY FUNCTION
+(LAMBDA (X X) . 5)
+PROPERTYEXISTS FUNCTION
+(LAMBDA (X X) . 6)
+PROPERTY FUNCTION
+(LAMBDA (X X) . 7)
+ADDFLAG FUNCTION
+(LAMBDA (X X) . 8)
+FLAG FUNCTION
+(LAMBDA (X X) . 9)
+DELETEFLAG FUNCTION
+(LAMBDA (X X) . 10)
+BEGINPROPERTYLISTDUMP FUNCTION
+(LAMBDA (X) . 11)
+NEXTPROPERTY FUNCTION
+(LAMBDA () . 12)
+APPLY FUNCTION
+(LAMBDA (X X X) . 13)
+EVAL FUNCTION
+(LAMBDA (X X) . 14)
+TRY FUNCTION
+(LAMBDA (X X X X) . 15)
+ASSOCIATIONLIST FUNCTION
+(LAMBDA () . 16)
+ERRORSTOP FUNCTION
+(LAMBDA (X) . 17)
+HEAD FUNCTION
+(LAMBDA (X) . 18)
+SETHEAD FUNCTION
+(LAMBDA (X X) . 19)
+TAIL FUNCTION
+(LAMBDA (X) . 20)
+SETTAIL FUNCTION
+(LAMBDA (X X) . 21)
+CONS FUNCTION
+(LAMBDA (X X) . 22)
+EQ FUNCTION
+(LAMBDA (X X) . 23)
+GET FUNCTION
+(LAMBDA () . 24)
+PUT FUNCTION
+(LAMBDA (X) . 25)
+NULL FUNCTION
+(LAMBDA (X) . 26)
+ATOM FUNCTION
+(LAMBDA (X) . 27)
+NAMEDATOM FUNCTION
+(LAMBDA (X) . 28)
+GETATOM FUNCTION
+(LAMBDA () . 29)
+PUTATOM FUNCTION
+(LAMBDA (X) . 30)
+TEXT FUNCTION
+(LAMBDA (X) . 31)
+GETTEXT FUNCTION
+(LAMBDA () . 32)
+PUTTEXT FUNCTION
+(LAMBDA (X) . 33)
+CHARACTER FUNCTION
+(LAMBDA (X) . 34)
+GETCHARACTER FUNCTION
+(LAMBDA () . 35)
+PUTCHARACTER FUNCTION
+(LAMBDA (X) . 36)
+INT FUNCTION
+(LAMBDA (X). 37)
+GETINT FUNCTION
+(LAMBDA () . 38)
+PUTINT FUNCTION
+(LAMBDA (X) . 39)
+SUM FUNCTION
+(LAMBDA ((INDEFINITE X)) . 40)
+DIFFERENCE FUNCTION
+(LAMBDA (X X). 41)
+PRODUCT FUNCTION
+(LAMBDA ((INDEFINITE X)). 42)
+QUOTIENT FUNCTION
+(LAMBDA (X X).43)
+REMAINDER FUNCTION
+(LAMBDA (X X).44)
+EQUAL FUNCTION
+(LAMBDA (X X) . 45)
+TRACE FUNCTION
+(LAMBDA () . 46 )
+DEFINE FUNCTION
+(LAMBDA ((INDEFINITE X)) . 47 )
+SET FUNCTION
+(LAMBDA (X X) . 48 )
+QUOTE FUNCTION
+(LAMBDA ((QUOTE X)) X)
+LIST FUNCTION
+(LAMBDA ((INDEFINITE X)) X)
+DO FUNCTION
+(LAMBDA ((INDEFINITE X)) NIL)
+PUTLIST FUNCTION
+(LAMBDA ((INDEFINITE X))
+ (COND
+ ((NULL X) NIL)
+ (T (DO (PUT (HEAD X)) (PUTLIST (TAIL X))))
+ )
+)
diff --git a/lang/lisp/1.8.7/doc/lisp handbuch b/lang/lisp/1.8.7/doc/lisp handbuch new file mode 100644 index 0000000..022c561 --- /dev/null +++ b/lang/lisp/1.8.7/doc/lisp handbuch @@ -0,0 +1,2260 @@ +____________________________________________________________________________ + + +#on("b")##on ("u")# +#center#Betriebssystem E U M E L +#off ("u")# + + +#center#Lisp + + + + +#off("b")# +#center#Lizenzfreie Software der +#on ("b")# + +#center#Gesellschaft für Mathematik und Datenverarbeitung mbH, +#center#5205 Sankt Augustin + + +#off("b")# +#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für +#center#nichtkommerzielle Zwecke gestattet. + +#center#Gewährleistung und Haftung werden ausgeschlossen + + +____________________________________________________________________________ +#page# +#free(7.0)# +#center#LISP - Handbuch +#free(2.0)# +Stand: 08.08.86 + +Installation von LISP + +begin ("LISP") +reserve ("sprachen",archive) +fetch all(archive) +insert ("lisp.1") +insert ("lisp.2") +insert ("lisp.3") +insert ("lisp.4") +global manager +begin ("lisp","LISP") +fetch ("lisp.bootstrap") +lisp +#page# +#start(2.5,1.5)# +#block# +#pageblock# +#head# +#center#LISP-Handbuch +#center#% + + +#end# + + +#center#L I S P H a n d b u c h + + +#center#Autor: John Mc.Carthy (M.I.T.1962) +#center#übersetzt und angepaßt von J.Durchholz, P.Heyderhoff +#center#Gesellschaft für Mathematik und Datenverarbeitung Sankt Augustin + + + +Inhaltsverzeichnis + + + +1. Die Sprache LISP #right##topage("p1")# + +1.1 Symbolische Ausdrücke #right##topage("p1.1")# +1.2 Elementare Funktionen #right##topage("p1.2")# +1.3 Listen Notation #right##topage("p1.3")# +1.4 Syntax und Semantik der Sprache #right##topage("p1.4")# + +2. Das LISP-Interpreter-System #right##topage("p2")# + +2.1 Die universelle LISP-Funktion "evalquote" #right##topage("p2.1")# +2.2 Anwendungsregeln und Beispiele #right##topage("p2.2")# +2.3 Variablen #right##topage("p2.3")# +2.4 Konstanten #right##topage("p2.4")# +2.5 Funktionen #right##topage("p2.5")# + +3. Erweitertes LISP #right##topage("p3")# + +3.1 Gequotete Parameter #right##topage("p3.1")# +3.2 Funktionen mit beliebig vielen Parametern #right##topage("p3.2")# +3.3 Funktionale Parameter #right##topage("p3.3")# +3.4 Prädikate und boolesche Konstanten #right##topage("p3.4")# +3.5 Unbenannte Atome #right##topage("p3.5")# +3.6 Aufruf von EUMEL aus #right##topage("p3.6")# + +4. Detailbeschreibungen #right##topage("p4")# + +4.1 Grundfunktionen #right##topage("p4.1")# +4.2 Weitere Funktionen sowie Eingabe und Ausgabe #right##topage("p4.2")# +4.3 Interpreter #right##topage("p4.3")# +4.4 Kommandoprozeduren #right##topage("p4.4")# +#page# + +1. Die Sprache LISP#goalpage("p1")# + + + +Die Sprache LISP ist primär für die Symbolmanipulation entworfen. Sie wurde für +symbolische Berechnungen in verschiedenen Gebieten der künstlichen Intelligenz +eingesetzt, u.a. für Differential- und Integralrechnung, Schaltkreistheorie, Mathemati +sche Logik, Spiele, etc.. + +LISP ist eine formale mathematische Sprache. Daher ist es möglich, eine genaue und +vollständige Beschreibung zu geben. Das ist der Sinn des ersten Abschnitts dieses +Handbuchs. Andere Abschnitte werden Möglichkeiten zum vorteilhaften Einsatz von +LISP und die Erweiterungen, die die Benutzung erleichtern, beschreiben. + +LISP unterscheidet sich von den meisten Programmiersprachen in drei Punkten. + +Der erste Punkt liegt in der Natur der Daten. In der Sprache LISP haben alle Daten +die Form symbolischer Ausdrücke, die wir verkürzend LISP-Ausdrücke nennen wer +den. LISP-Ausdrücke haben keine Längenbegrenzung und eine verzweigte Baum +struktur, so daß Unterausdrücke leicht isoliert werden können. In LISP wird der meiste +Speicherplatz für das Abspeichern der LISP-Ausdrücke in Form von Listenstruktu +ren gebraucht. + +Der zweite wichtige Teil der Sprache LISP ist die Quellsprache, die festlegt, wie die +LISP-Ausdrücke verarbeitet werden sollen. + +Drittens kann LISP als LISP-Ausdrücke geschriebene Programme interpretieren und +ausführen. Deshalb kann man die Sprache analog zu Assemblersprachen und im +Gegensatz zu den meisten anderen höheren Programmiersprachen einsetzen, um +Programme zu generieren, die gleich ausgeführt werden sollen. + + +#page# + +1.1 Symbolische Ausdrücke #goalpage("p1.1")# + + + +Ein elementarer Ausdruck ist ein Atom. + +Definition: Ein Atom ist eine Zeichenkette bestehend aus Großbuchstaben und + Ziffern. + + +Beispiele: A + APFEL + TEIL2 + EXTRALANGEZEICHENKETTEAUSBUCHSTABEN + A4B66XYZ2 + + +Diese Symbole werden atomar genannt, weil sie als Ganzes aufgefaßt werden, das +durch die LISP-Funktionen nicht weiter geteilt werden kann. A, B, und AB haben +keinerlei Beziehung zueinander, außer der, daß sie alle verschiedene Atome sind. + +Alle LISP-Ausdrücke werden aus Atomen und den Satzzeichen "(", ")" und "." +aufgebaut. Die grundlegende Operation zum Aufbau von LISP-Ausdrücken ist die, +zwei LISP-Ausdrücke zusammenzufassen, um einen größeren herzustellen. Aus den +zwei Atomen A und B kann man so den LISP-Ausdruck (A.B) bilden. + +Definition: Ein LISP-Ausdruck ist entweder ein Atom, oder aus folgenden Elemen + ten in dieser Reihenfolge aufgebaut: Eine öffnende Klammer, ein + LISP-Ausdruck, ein Punkt, ein LISP-Ausdruck, eine schließende + Klammer. Zwischen den Bestandteilen eines nichtatomaren LISP-Aus + druck können beliebig viele Leerzeichen eingestreut sein. + +Diese Definition ist rekursiv. + + +Beispiele: ATOM + (A . B) + (A . (B . C)) + ((A1 . A2) . B) + ((U . V) . (X . Y)) + ((U . V) . (X . (Y . Z))) + + +Um die Struktur solcher Ausdrücke zu verdeutlichen, wird in diesem Handbuch oft +eine graphische Darstellung gewählt. In dieser Darstellung sind die Atome weiterhin +Zeichenketten, statt der Paare steht jetzt aber ein Kasten + + + +-----+-----+ + | o | o | + +-----+-----+ + + +von dem zwei Zeiger ausgehen, die auf die graphische Darstellung des ersten bzw. +zweiten Elements des Paars zeigen. + + + +Beispiele: (A . B) +-----+-----+ + | o | o | + +--+--+--+--+ + | | + V V + A B + + (A . (B . C)) +-----+-----+ + | o | o | + +--+--+--+--+ + | | + V V + A +-----+-----+ + | o | o | + +--+--+--+--+ + | | + V V + B C + + ((U . V) . (X . (Y . Z))) +-----+-----+ + | o | o | + +--+--+--+--+ + | | + V V + +-----+-----+ +-----+-----+ + | o | o | | o | o | + +--+--+--+--+ +--+--+--+--+ + | | | | + V V V V + U V X +-----+-----+ + | o | o | + +--+--+--+--+ + | | + V V + Y Z + + + + + + +#page# + +1.2 Elementare Funktionen #goalpage("p1.2")# + + +Wir werden einige elementare Funktionen auf LISP-Ausdrücken einführen. Um die +Funktionen von den LISP-Ausdrücken zu unterscheiden, werden wir Funktionsnamen +mit Klein- statt Großbuchstaben schreiben. Außerdem steht der Funktionsname +gefolgt von den Argumenten, auf die die Funktion angewendet werden soll, in Klam +mern eingeschlossen in einer Liste. Dabei sind die Argumente durch Blanks vonein +ander getrennt. + +Die erste Funktion, die wir einführen, heißt "cons". Sie hat zwei Argumente und wird +dafür benutzt, LISP-Ausdrücke aus kleineren LISP-Ausdrücken aufzubauen. + + + Funktionsaufruf: Ergebnis: + +Beispiele: (cons A B) = (A . B) + (cons (A . B) C) = ((A . B) . C) + (cons (cons A B) C) = ((A . B) . C) + + +Die Beispiele zeigen Funktionsaufrufe. Ein Funktionsaufruf ist eine Liste beginnend +mit einem Funktionsnamen, gefolgt von Argumenten. Alle Funktionsaufrufe haben ein +Ergebnis, das im Fall von LISP-Funktionen immer ein LISP-Ausdruck ist. + +In diesen Beispielen kommt nur die Funktion "cons" vor. Das letzte Beispiel ist ein +Fall von Funktionsverkettung, das heißt, als Argument steht ein Funktionsaufruf. Um +das Ergebnis eines Funktionsaufrufs zu berechnen, das Funktionsaufrufe als Argu +mente enthält, muß man statt dieser Argumente die Ergebnisse dieser Funktionsaufru +fe einsetzen, so daß man den äußeren Funktionsaufruf in einen Aufruf ohne Funk +tionsaufrufe als Argumente umwandelt. + + +Beispiel: (cons (cons A B) C) = (cons (A . B) C) = ((A . B) . C) + + +Es ist möglich, durch Verkettung der Funktion "cons" jeden LISP-Ausdruck aus +seinen atomaren Komponenten aufzubauen. + +Die folgenden beiden Funktionen tun das genaue Gegenteil von "cons": sie liefern +die Unterausdrücke eines gegebenen LISP-Ausdrucks. + +Die Funktion "head" hat ein Argument. Ihr Wert ist der erste Unterausdruck des +zusammengesetzen Arguments. Der "head" eines Atoms ist nicht definiert. + + +Beispiele: (head (A . B)) = A + (head (A . (B1 . B2))) = A + (head ((A1 . A2) . B)) = (A1 . A2) + (head A) ist nicht definiert + + +Die Funktion "tail" hat ebenfalls ein Argument, und sie liefert das Argument bis auf +dessen "head". + + +Beispiele: (tail (A . B)) = B + (tail (A . (B1 . B2))) = (B1 . B2) + (tail ((A1 . A2) . B)) = B + (tail A) ist nicht definiert + (head (tail (A . (B1 . B2)))) = B1 + (head (tail (A . B))) ist nicht definiert + (head (cons A B)) = A + + +Es ist bei jedem LISP-Ausdruck möglich, durch eine geeignete Verkettung von +"head" und "tail" zu jedem Atom im Ausdruck zu gelangen. + +Wenn "x" und "y" irgendwelche LISP-Ausdrücke repräsentieren, gelten die folgen +den Gleichungen immer: + + + (head (cons x y)) = x + (tail (cons x y)) = y + + +Außerdem gilt die folgende Gleichung für jeden nichtatomaren LISP-Ausdruck "z": + + + (cons (head z) (tail z)) = z +9 + +Die Symbole "x", "y" und "z", die wir in diesen Gleichungen benutzt haben, nennt +man Variablen. In LISP werden Variable benutzt, um LISP-Ausdrücke zu repräsentie +ren, und zwar repräsentiert eine Variable in einer Gleichung immer denselben +LISP-Ausdruck. Variablennamen werden wie Funktionsnamen gebildet, d.h. sie +können Kleinbuchstaben und Ziffern enthalten. + +Eine Funktion, deren Wert "wahr" oder "falsch" sein kann, wird Prädikat genannt. In +LISP werden die Werte "wahr" und "falsch" durch die Atome "T" (true) und "F" +(false) vertreten. Ein LISP-Prädikat ist also eine Funktion, deren Wert entweder "T" +oder "F" ist. + +Das Prädikat "eq" ist ein Gleichheitstest für Atome. Es ist bei nicht atomaren Argu +menten nicht definiert. + + +Beispiele: (eq A A) = T + (eq A B) = F + (eq A (A . B)) ist nicht definiert + (eq (A . B) B) ist nicht definiert + (eq (A . B) (A . B)) ist nicht definiert + + +Das Prädikat "atom" hat das Ergebnis ("liefert") "T", wenn sein Argument atomar ist, +und "F", wenn sein Argument zusammengesetzt ist. + + +Beispiele: (atom EXTRALANGEZEICHENKETTE) = T + (atom (U . V)) = F + (atom (head (U . V))) = T + +#page# + +1.3 Listen-Notation #goalpage("p1.3")# + + + +Alle LISP-Ausdrücke, die wir bisher gesehen haben, waren in Punkt-Notation +geschrieben. Normalerweise ist es allerdings einfacher, statt der vielen Punkte und +Klammern Listen von LISP-Ausdrücken zu schreiben, etwa in der Art (A B C XYZ). + +LISP bietet eine solche Alternative zur Punkt-Notation an: + +Definition: Die Liste (a1 a2 ... an) ist äquivalent zum LISP-Ausdruck + (a1 . (a2 . (... . (an . NIL) ... ))). + +Graphisch ausgedrückt heißt das: + + + +-----+-----+ + | o | o | + +--+--+--+--+ + | | + V V + a1 +-----+-----+ + | o | o | + +--+--+--+--+ + | | + V V + a2 + . + . + . + + +-----+-----+ + | o | o | + +--+--+--+--+ + | | + V V + an NIL + + + +Oft werden wir für Listen auch die graphische Form + + + +-----+-----+ +-----+-----+ +-----+-----+ + | o | o--+-->| o | o--+--> . . . | o | o--+--> NIL + +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | + V V V + a1 a2 an + + +benutzen. + +Aus der Graphik wird deutlich, daß NIL als eine Art Abschlußmarkierung für Listen +dient. + +Eine leere Liste wird durch das Atom NIL dargestellt. Das Prädikat "null" liefert "T", +wenn sein Argument eine leere Liste ist, sonst "F". + + +Beispiele: (null NIL) = T + (null () ) = T + (null (A B)) = F + + +Die Listenelemente können selbst wieder Listen oder Paare in Punkt-Notation sein, +so daß Listen- und Punkt-Notation beliebig kombinierbar sind. + + + Beispiele: (A B C) = (A . (B . (C . NIL))) + + +-----+-----+ +-----+-----+ +-----+-----+ + | o | o--+-->| o | o--+-->| o | o--+--> NIL + +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | + V V V + A B C + + ((A . B) C) = ((A . B) . (C . NIL)) + + +-----+-----+ +-----+-----+ + | o | o--+-->| o | o--+--> NIL + +--+--+-----+ +--+--+-----+ + | | + V V + +-----+-----+ C + | o | o | + +--+--+--+--+ + | | + V V + A B + + ((A B) C) = ((A . (B . NIL)) . (C . NIL)) + + +-----+-----+ +-----+-----+ + | o | o--+--------------->| o | o--+--> NIL + +--+--+-----+ +--+--+-----+ + | | + | V + V C + +-----+-----+ +-----+-----+ + | o | o--+-->| o | o--+--> NIL + +--+--+-----+ +--+--+-----+ + | | + V V + A B + + (A) = (A . NIL) + + +-----+-----+ + | o | o--+--> NIL + +--+--+-----+ + | + V + A + + ((A)) = ((A . NIL) . NIL) + + +-----+-----+ + | o | o--+--> NIL + +--+--+-----+ + | + V + +-----+-----+ + | o | o--+--> NIL + +--+--+-----+ + | + V + A + + + + + +Es ist sehr hilfreich, mit den Ergebnissen der elementaren Funktionen vertraut zu +sein, wenn diese Listen als Argumente erhalten. Zwar können die Ergebnisse notfalls +immer durch Übersetzung in Punkt-Notation bestimmt werden, aber ein direktes +Verständnis ist einfacher. + + +Beispiele: (head (A B C)) = A + (tail (A B C)) = (B C) + + + (Daher auch die Namen "head" und "tail"! Frei übersetzt heißen die + beiden Funktionen "anfang" und "rest".) + + + (cons A (B C)) = (A B C) + +#page# + +1.4 Syntax und Semantik der Sprache #goalpage("p1.4")# + + + +Wir haben bisher einen Datentyp (LISP-Ausdrücke) und fünf elementare Funktionen +eingeführt. Außerdem haben wir die folgenden Eigenschaften der Sprache beschrie +ben: + +1. Funktions- und Variablennamen werden wie die Namen von Atomen geschrie + ben, außer, daß dafür Klein- statt Großbuchstaben verwendet werden. +2. Die Argumente einer Funktion folgen dieser in der Liste. Eine solche Liste von + Funktion und folgenden Argumenten heißt Funktionsaufruf und hat einen LISP- + Ausdruck als Ergebnis. +3. Funktionen können dadurch verkettet werden, daß ein Argument aus einem Funk + tionsaufruf selbst wieder ein Funktionsaufruf ist, dessen Argumente selbst wieder + Funktionsaufrufe sein können, usw. + +Diese Regeln erlauben es, Funktionsdefinitionen wie + + + (third x) = (head (tail (tail x))) + + +zu schreiben. "third" holt das dritte Element aus einer Liste. + +Die Klasse der Funktionen, die man auf diese Weise bilden kann, ist ziemlich be +schränkt und nicht sehr interessant. Eine viel größere Funktionenklasse kann man mit +Hilfe des bedingten Ausdrucks schreiben; es handelt sich dabei um eine Möglichkeit, +Verzweigungen in Funktionsdefinitionen einzubauen. + +Ein bedingter Ausdruck hat die Form + + + (cond (p1 a1) (p2 a2) ... (pn an) ) + + +Jedes pi ist ein Ausdruck, dessen Wert "T" oder "F" ist, also ein Prädikat. Die ai +sind beliebige LISP-Ausdrücke. + +Die Bedeutung eines bedingten Ausdrucks ist folgende: Wenn p1 wahr ist, ist a1 der +Wert des ganzen Ausdrucks. Wenn p1 falsch ist, wird getestet, ob p2 wahr ist; wenn +das der Fall ist, ist a2 der Wert des Ausdrucks. Die pi werden also von links nach +rechts durchgegangen, bis ein wahrer Ausdruck gefunden ist; das zugehörige ai ist +dann der Wert des bedingten Ausdrucks. Wenn kein wahres pi gefunden ist, ist der +bedingte Ausdruck nicht definiert. +Jedes pi oder ai kann selbst wieder ein LISP-Ausdruck, ein Funktionsaufruf oder ein +bedingter Ausdruck sein. + + +Beispiel: (cond ((eq (head x) A) (cons B (tail x))) (T x) ) + + +Das Prädikat "T" ist immer wahr. Man liest es am besten als "SONST". Den Wert +dieses Ausdruck erhält man, wenn man "head" von x durch B ersetzt, wenn der +gerade gleich mit A ist, und sonst erhält man x. + +Der Hauptzweck von bedingten Ausdrücken ist die rekursive Definition von Funktio +nen. + + +Beispiel: (firstatom x) = (cond ((atom x) x) + ( T (firstatom (head x))) + ) + + +Dies Beispiel definiert die Funktion "firstatom", die das erste Atom jedes LISP-Aus +drucks bestimmt. Diesen Ausdruck kann man so lesen: wenn "x" ein Atom ist, ist "x" +selbst die Antwort; sonst muß "firstatom" auf "head" von "x" angewandt werden. + +Wenn also "x" ein Atom ist, wird der erste Zweig gewählt, der "x" liefert; sonst wird +der zweite Zweig "firstatom (head x)" gewählt, weil "T" immer wahr ist. + +Die Definition von "firstatom" ist rekursiv, d.h. "firstatom" ist mit durch sich selbst +definiert. Allerdings, wenn man immerzu den "head" von irgendeinem LISP-Aus +druck nimmt, errreicht man irgendwann ein Atom, so daß der Prozeß immer wohlde +finiert ist. + +Es gibt rekursive Funktionen, die nur für bestimmte Argumente wohldefiniert sind, für +bestimmte andere dagegen unendlich rekursiv. Wenn das EUMEL-LISP-System +einen Funktionsionsaufruf mit einer solchen Funktion und "kritischen" Argumenten +interpretiert, gerät es in unendliche Rekursion, bis entweder der zur Verfügung ste +hende Platz im LISP-Heap ausgeschöpft ist (im Heap werden die LISP-Ausdrücke +gespeichert) oder bis der Laufzeitstack überläuft (der Laufzeitstack ist ein normaler +weise unsichtbarer Bestandteil des ELAN-Systems). +Wir werden jetzt die Berechnung von "(firstatom ((A . B) . C))" durchführen. Zunächst +ersetzen wir die Variable x in der Funktionsdefinition durch ((A . B) . C) und erhalten + + + (firstatom ((A . B) . C)) = + (cond ( (atom ((A . B) . C)) ((A . B) . C) ) + ( T (firstatom (head ((A . B) . C))) ) + ) + +((A . B) . C) ist kein Atom, deshalb wird daraus + + = (cond ( T (firstatom (head ((A . B) . C)))) ) + = (firstatom (head ((A . B) . C)) ) + = (firstatom (A . B)) + + + +An diesem Punkt müssen wir wieder die Definition von "firstatom" benutzen, diesmal +aber für "x" überall "(A . B)" einsetzen. + + + (firstatom (A . B)) = (cond ( (atom (A . B)) (A . B) ) + (T (firstatom (head (A . B))) ) + ) + = (cond (T (firstatom (head (A . B))) ) ) + = (firstatom (head (A . B)) ) + = (firstatom A) + = (cond ((atom A) A) + (T (firstatom (head A)) ) + ) + = A + + +Wenn in den bedingten Ausdrücken statt der LISP-Ausdrücke arithmetische Aus +drücke verwendet würden, könnte man damit auch numerische Rechenvorschriften +definieren, wie z.B. den Betrag einer Zahl durch + + + (abs x) = (cond ((x < 0) -x) (T x) ) + + +oder die Fakultät durch + + + (fak n) = (cond ((n = 0) 1) + (T (x * (fak (n - 1)))) + ) + + +Die Fakultät terminiert bei negativen Argumenten nicht. + +Es ist bei den meisten Mathematikern (außer den Logikern) üblich, das Wort "Funk +tion" nicht präzise zu verwenden und auf Ausdrücke wie "2x+y" anzuwenden. Da wir +Ausdrücke benutzen werden, die Funktionen repräsentieren, benötigen wir eine +Notation, die Funktionen und Ausdrücke unterscheidet. Dafür ist die Lambda-Nota +tion von Alonzo Church geeignet. +"f" soll ein Ausdruck sein, der für eine Funktion zweier ganzzahliger Variablen steht. + +Dann sollte es sinnvoll sein, den Funktionsaufruf + + + (f 3 4) + + +zu schreiben, so daß man dadurch den Wert dieses Funktionsaufrufs berechnen kann; +z.B. könnte "(summe 3 4) = 7" gelten. + +Wenn man "2x + y" als Funktion ansieht, kann man den Funktionsaufruf + + + ((2x + y) 3 4) + + +schreiben. Der Wert dieses Ausdrucks ist aber nicht eindeutig bestimmt, denn es ist +überhaupt nicht klar, ob nun "2*3+4" oder 2*4+3" gemeint ist. Eine Zeichenfolge +wie "2x + y" werden wir deshalb Ausdruck und nicht Funktion nennen. Ein Ausdruck +kann in eine Funktion umgewandelt werden, indem man die Zuordnung von Argumen +ten und Variablen festlegt. Bei "2x + y" könnte man beispielsweise festlegen, daß +"x" immer das erste und "y" immer das zweite Argument sein soll. +Wenn "a" ein Ausdruck in den Variablen x1, ... xn ist, dann ist + + + (lambda (x1 ... xn) a) + + +eine Funktion mit n Argumenten. Den Wert der Funktionsaufrufe mit dieser Funktion +(also der Ausdrücke der Form + + + ((lambda (x1 ... xn) a) (b1 ... bn)) + erhält man, indem man die Variablen x1 ... xn durch die n Argumente des Aufrufs +ersetzt. Beispielsweise ist + + + ((lambda (x y) (2*x + y)) (3 4)) = 2*3 + 4 = 10 , + + +während + + + ((lambda (y x) (2*x + y)) (3 4)) = 2*4 + 3 = 11 + + +ist. + +Die Variablen in einem Lambdaausdruck sind sogenannte Parameter (oder gebundene +Variable). Interessant ist, daß eine Funktion sich nicht ändert, wenn man eine Variable +systematisch durch eine andere Variable ersetzt, die nicht bereits im Lambdaausdruck +vorkommt. + + + (lambda (x y) (2*y + x)) + + +ist also dasselbe wie + + + (lambda (u v) (2*v + u)) . + + +Manchmal werden wir Ausdrücke benutzen, in denen eine Variable nicht durch das +Lambda gebunden ist. Beispielsweise ist das n in + + + (lambda (x y) (x*n + y*n)) + + +nicht gebunden. Eine solche nicht gebundene Variable nennt man frei. +Wenn für eine freie Variable vor der Benutzung kein Wert vereinbart wurde, ist der +Wert des Funktionsaufrufs nicht definiert, falls der Wert der Variablen auf das Ergeb +nis einen Einfluß hat. + +Die Lambdanotation reicht allein für die Definition rekursiver Funktionen nicht aus. +Neben den Variablen muß auch der Name der Funktion gebunden werden, weil er +innerhalb der Funktion für eine Zeichenfolge steht. + +Wir hatten die Funktion "firstatom" durch die Gleichung + + + (firstatom x) = (cond ((atom x) x) + (T (firstatom (head x))) + ) + + +definiert. Mit der Lambda-Notation können wir schreiben: + + + firstatom = (lambda (x) (cond ((atom x) x) + (T (firstatom (head x))) + ) ) + + + +Das Gleichheitszeichen ist in Wirklichkeit nicht Teil der LISP-Sprache, sondern eine +Krücke, die wir nicht mehr brauchen, wenn wir die richtige Schreibweise eingeführt +haben. + +Die rechte Seite der obigen Gleichung ist als Funktion nicht vollständig, da dort nichts +darauf hinweist, daß das "firstatom" im einem bedingten Ausdruck für eben die rechte +Seite steht. Deshalb ist die rechte Seite als Definition für die linke Seite ("firstatom") +noch nicht geeignet. + +Damit wir Definitionen schreiben können, in denen der Name der gerade definierten +Funktion auftaucht, führen wir die Label-Notation ein (engl. label = Marke, (Preis-) +Schildchen). Wenn "a" eine Funktion ist, und "n" ihr Name, schreiben wir "(label n +a)". + +Nun können wir die Funktion "firstatom" ohne Gleichheitszeichen schreiben: + + + (label firstatom (lambda (x) (cond ((atom x) x) + (T (firstatom (head x))) + ) ) ) + + +In dieser Definition ist "x" eine gebundene Variable und "firstatom" ein gebundener +Funktionsname. +#page# + +2. Das LISP-Interpreter-System#goalpage("p2")# + + + +2.1 Die universelle LISP-Funktion + "evalquote" #goalpage("p2.1")# + + + +Ein Interpreter oder eine allgemeine Funktion ist eine Funktion, die den Wert jedes +gegebenen Ausdrucks berechnen kann, wenn der Ausdruck in einer geeigneten Form +vorliegt. (Wenn der zu interpretierende Ausdruck einen Aufruf einer unendlich rekur +siven Funktion enthält, wird der Interpreter natürlich ebenfalls unendlich rekursiv.) +Wir sind jetzt in der Lage, eine allgemeine LISP-Funktion + + + (evalquote function arguments) + + +zu definieren. "evalquote" muß als erstes Argument ein LISP-Ausdruck übergeben +werden. Dieser wird als Funktion aufgefasst und auf die folgenden Argumente ange +wendet. + +Im Folgenden sind einige nützliche Funktionen zur Manipulation von LISP-Aus +drücken angegeben. Einige von ihnen werden als Hilfsfunktionen für die Definition von +"evalquote" gebraucht, die wir uns vorgenommen haben. + + + (equal x y) + + +ist ein Prädikat, das wahr ist, wenn seine Argumente gleiche LISP-Ausdrücke sind. +(Das elementare Prädikat "eq" ist ja nur für Atome definiert.) + +Die Definition von "equal" ist ein Beispiel für einen bedingten Ausdruck innerhalb +eines bedingten Ausdrucks. + + +(label equal + (lambda (x y) + (cond + ((atom x) (cond + ((atom y) (eq x y)) + (T F) + ) + ) + ((equal (head x) (head y)) (equal (tail x) (tail y))) + (T F) + ) + ) +) + + + +Folgende Funktion liefert einen LISP-Ausdruck, der gleich mit "destination" ist, +außer daß darin überall statt "old" "new" steht. + + +(changeall (destination old new)) + += (cond ((equal destination old) new) + ((atom destination) destination) + (T (cons (changeall (head destination) old new) + (changeall (tail destination) old new) + ) + ) + ) + + +Beispielsweise gilt + + +(changeall ((A . B) . C) B (X . A)) = ((A . (X . A)) . C) + + +Die folgenden Funktionen sind nützlich, wenn Listen verarbeitet werden sollen. + +1. (append x y) + hängt an die Liste "x" den LISP-Ausdruck "y". + + + (append x y) = + (cond ((null x) y) + (T (cons (head x) (append (tail x) y) )) + ) + + +2. (member list pattern) + Dies Prädikat testet, ob der LISP-Ausdruck "pattern" in der Liste "list" vor + kommt. + + + (member list pattern) = + (cond ((null list) F) + ((equal (head list) pattern) T) + (T (member (tail list) pattern)) + ) + + +3. (pairlist list1 list2 oldpairlist) + Diese Funktion liefert eine Liste von Paaren, die die sich entsprechenden Elemen + te der Listen "list1" und "list2" enthalten, und an der noch die Liste "oldpairlist" + hängt. + + + + (pairlist list1 list2 oldpairlist) = + (cond ((null list1) oldpairlist) + (T (cons (cons (head list1) (head list2)) + (pairlist (tail list1) (tail list2) oldpairlist) + ) + ) + ) + + +Beispiel: + (pairlist (A B C) (U V W) ((D . X) (E . Y)) ) = + ((A . U) (B . V) (C . W) (D . X) (E . Y)) + + +Eine solche Liste von Paaren wird auch Assoziationsliste genannt, wenn das erste +Element jedes Paars ein Atom ist, das über diese Liste mit dem zweiten Element +assoziiert ist. + +5. (association pattern associationlist) + Wenn "association list" eine Assoziationsliste wie oben beschrieben ist, liefert + "association" das Paar der Liste, dessen erstes Element "pattern" ist. Es ist also + eine Funktion zum Durchsuchen von Tabellen. + + + (association pattern alist) = + (cond ((eq (head (head alist)) pattern) (head alist)) + (T (association pattern (tail alist))) + ) + +Beispiel: + +(association B ( (A . (M N)) + (B . (HEAD X)) + (C . (QUOTE M)) + (B . (TAIL X)) + ) ) = (B . (HEAD X)) + + +(replace expr alist) + "alist" muß eine Assoziationsliste sein. "replace" produziert einen Ausdruck, der + "expr" sehr ähnlich ist, nur sind alle Atome darin durch den LISP-Ausdruck + ersetzt, mit dem sie in "alist" assoziiert sind. + + + (replace expr alist) = + (cond ((atom expr) (association expr alist)) + (T (cons (replace (head expr) alist) + (replace (tail expr) alist) + ) + ) + ) + +Beispiel: + + (replace (X SCHRIEB Y) + ((Y . (GOETZ VON BERLICHINGEN)) (X . GOETHE)) + ) + + = (GOETHE SCHRIEB (GOETZ VON BERLICHINGEN)) + + + +Die allgemeine Funktion "evalquote", die wir jetzt definieren wollen, gehorcht der +folgendem Beispiel zugrundeliegenden Regel: + + +Beispiel: + (evalquote +Funktion: (LAMBDA (X Y) (CONS (HEAD X) Y) ) +Argumente: (A B) (C D) + ) += + (apply +Funktion: (LAMBDA (X Y) (CONS (HEAD X) Y)) +Argumentliste: ((QUOTE (A B)) (QUOTE (C D))) +Bindung: NIL + ) + + +Die Argumente von "evalquote" werden also zu einer gequoteten Argumentliste von +"apply". Die QUOTE-Funktion bewirkt, daß das Argument der QUOTE-Funktion +wörtlich genommen, also nicht weiter evaluiert wird. Das dritte Argument von "apply", +das NIL ist eine leere Bindeliste zur Bindung von Parametern und Argumenten im +nächsten Schritt: + + += + (eval +Argumente: (CONS (HEAD X) Y) +Bindung: ((X.(A B)) (Y . (C D))) + ) += + (cons (head (A B)) (C D)) += + (A C D) = Ergebnis von "evalquote" . + + +"evalquote" wird hauptsächlich durch die Hilfsfunktion "apply" definiert. "apply" +berechnet Funktionsaufrufe, indem es die Argumente und die Parameter der Funktion +bindet und den Funktionsrumpf berechnet. Die Bindungen werden in einer Assozia +tionsliste, der Bindeliste, gespeichert. Da bedingte Ausdrücke und Konstanten formal +wie Funktionsaufrufe von Funktionen "cond" und "quote" aussehen, werden sie auch +so behandelt. + +Wir definieren also: + + + (evalquote fkt expr) = (apply fkt (quote expr) NIL) . + + +sowie : + + + (eval expr binding) = + (cond ((atom expr) (tail (association expr binding))) + (T (apply (head expr) (tail expr) binding)) + ) + + +"eval" stellt also erst fest, ob es sich um ein Atom oder um einen Funktionsaufruf +handelt. Da es nur diese beiden Möglichkeiten gibt, ist diese Einteilung vollständig. + +Atome sind immer Übersetzungen von Variablen, für die eine Bindung existieren muß, +so daß ihr Wert aus der Bindeliste geholt wird. + +Funktionsaufrufe sind immer Listen; im zweiten Zweig werden die Funktion und die +Parameterliste getrennt und an "apply" übergeben. + +Um sich die Aktionen in diesem zweiten Zweig von "eval" genauer vorstellen zu +können, ist vielleicht die in Abschnitt 1.1 beschriebene graphische Darstellungsmetho +de hilfreich; beispielsweise würde sich ein Lambda-Ausdruck so ausnehmen: + + + +-----+-----+ +-----+-----+ +-----+-----+ + | o | o--+-->| o | o--+-->| o | o--+-->NIL + +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | + V V V + LAMBDA Parameterliste Ausdruck + + +"apply" bekommt nun von "eval" eine Funktion und eine Parameterliste sowie die +Bindeliste übergeben. Mit diesen beiden macht es folgendes: + + + (apply fn args binding) = +(cond + ((atom fn) + (cond ((eq fn HEAD) (head (eval (head args) binding))) + ((eq fn TAIL) (tail (eval (head args) binding))) + ((eq fn CONS) (cons (eval (head args) binding) + (eval (head (tail args)) binding) + ) ) + ((eq fn ATOM) (atom (eval (head args) binding))) + ((eq fn EQ) (eq (eval (head args) binding) + (eval (head (tail args)) binding) + ) ) + ((eq fn QUOTE) (head args)) + ((eq fn COND) (evalcond args binding)) + (T (apply (tail (association fn binding)) args binding)) + ) + ((eq (head fn) LABEL) + (apply (head (tail (tail fn))) + args (cons (cons (head (tail fn)) + (head (tail (tail fn))) + ) + binding) + ) ) + ((eq (head fn) LAMBDA) (eval (head (tail (tail fn))) + (pairlist (head (tail fn)) + args binding) + ) ) +) + + + + + + +Das erste Argument von "apply" ist eine Funktion (unter der Voraussetzung, daß +"quote" und "cond" als Funktionen anerkannt werden). + +Wenn es eine der elementaren Funktionen "head", "tail", "cons", "atom" oder "eq" +ist, wird die jweilige Funktion auf die Argumente angewandt, die vorher berechnet +werden. Diese Berechnung erfolgt mit "eval", das ja für Variablen Werte aus der +Bindeliste liefert und für Funktionsaufrufe das, was "apply" mit ihnen machen kann. + +Wenn es sich um "quote" handelt, wird das erste Argument unverändert geliefert +"quote" heißt ja "dies ist eine Konstante, die so, wie sie da steht, übernommen wer +den soll". + +Wenn es sich um "cond" handelt, wird die Funktion "eval cond" aufgerufen, doch +auch ihre Argumente werden nicht berechnet, außerdem gehört die Assoziationsliste +zu den Argumenten: + + + eval (cond condlist, binding) = + (cond ((eval (head (head condlist)) binding) + (eval (head (tail (head condlist))) binding) + ) + (T (cond (tail condlist) binding)) + ) + + + +Hier empfiehlt es sich, einen bedingten Ausdruck in graphischer Form hinzuschreiben +und die Auswertung anhand der Zeichnung nachzuvollziehen. + +Wenn die Funktion nichts von alledem ist, wird in der Bindeliste nachgesehen, ob +dies Atom nicht an eine Funktion gebunden ist; falls ja, wird eine Auswertung dieser +Funktion mit den gleichen Argumenten versucht. + +Wenn das erste Argument von "apply" kein Atom ist, muß es ein LABEL- oder ein +LAMBDA-Ausdruck sein. + +Ein LABEL-Ausdruck hat die Form + + + +-----+-----+ +-----+-----+ +-----+-----+ + | o | o--+-->| o | o--+-->| o | o--+--> NIL + +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | + V V V + LABEL Name Funktion + + +Funktionsname und Definition werden in einem funktionalen Eintrag in die Bindeliste +eingefügt, so daß der Name an die Funktion gebunden ist. + +Ein LAMBDA-Ausdruck hat die Form + + + +-----+-----+ +-----+-----+ +-----+-----+ + | o | o--+-->| o | o--+-->| o | o--+--> NIL + +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | + V V V + LAMBDA Parameterliste Ausdruck + + +Dabei ist die Parameterliste eine Liste von Atomen, den Parametern. Die Auswertung +läuft so ab, daß die Parameter durch "pairlist" an die Argumente gebunden werden +und mit dieser neuen Bindeliste der Ausdruck berechnet wird. + +Das EUMEL-LISP bietet eine Reihe weiterer Möglichkeiten, die erst später beschrie +ben werden. Hier können wir allerdings schon die folgenden Punkte abhandeln: + +1. Jede LISP-Eingabe ist ein LISP-Ausdruck. Der "head" dieses Ausdrucks wird + als Funktion aufgefaßt und auf den gequoteten "tail" des Ausdrucks, nämlich die + nicht zu evaluierenden Argumente angewandt. Die Übersetzung von Kleinbuchsta + ben in Großbuchstaben wird vom LISP-System übernommen. + +2. In der Theorie des reinen LISP müssen alle Funktionen außer den fünf Basisfunk + tionen an allen Stellen wieder definiert werden, an denen sie aufgerufen werden. + Das ist eine für die Praxis äußerst unhandliche Regelung; das EUMEL-LISP- + System kennt weitere vordefinierte Funktionen und bietet die Möglichkeit, beliebig + viele weitere Standardfunktionen einzuführen, auch solche Funktionen, deren + Argumente nicht berechnet werden (wie "quote") oder solche, die beliebig viele + Argumente haben dürfen (wie "cond"). + +3. Die Basisfunktion "eq" hat immer einen wohldefinierten Wert, dessen Bedeutung + im Fall, daß Nicht-Atome verglichen werden, im Kapitel über Listenstrukturen + erklärt wird. + +4. Außer in sehr seltenen Fällen schreibt man nicht (quote T), (quote F) oder (quote + NIL), sondern T, F und NIL. + +5. Es besteht die Möglichkeit, mit Ganzzahlen zu rechen, die als weiterer Typ von + Atomen gelten. Außerdem können TEXTe und Einzelzeichen (CHARACTERs) + gespeichert werden. + +6. Es besteht die Möglichkeit der Ein- und Ausgabe von LISP-Ausdrücken, Ganz + zahlen, TEXTen und CHARACTERs. + +WARNUNG: Die oben angegebenen Definitionen von "eval" und "apply" dienen nur + pädagogischen Zwecken und sind nicht das, was wirklich im Interpreter + abläuft. + Um zu entscheiden, was wirklich vor sich geht, wenn der Interpreter + aufgerufen wird, sollte man sich an die ELAN-Quellprogramme halten. +#page# + +2.2 Anwendungsregeln und Beispiele #goalpage("p2.2")# + + + +Die Funktionsweise des LISP-Interpreteres kann bequem unter Verwendung der +Funktion "trace" verfolgt werden. Der Aufruf: + + + (trace) + + +schaltet den Trace-Protokollmodus des Interpreters ein bzw. aus. + +Das folgende Beispiel ist ein LISP-Programm, das die drei Funktionen "union", +"intersection" und "member" als Standardfunktionen einführt Die Funktionen lauten +folgendermaßen: + + + (member pattern list) = (cond ((null list) F) + ((eq (head list) pattern) T) + (T (member pattern (tail list))) + ) + + (union x y) = (cond ((null x) y) + ((member (head x) y) (union (tail x) y)) + (T (cons (head x) (union (tail x) y))) + ) + + (intersection x y) = (cond ((null x) NIL) + ((member (head x) y) + (cons (head x) (intersection + (tail x) y)) + ) + (T (intersection (tail x) y)) + ) + + +Um die Funktionen als neue Standardfunktionen einzuführen, benutzen wir die Pseu +dofunktion "define": + + + (DEFINE + (MEMBER . (LAMBDA (PATTERN LIST) + (COND ((NULL LIST) F) + ((EQ (HEAD LIST) PATTERN) T) + (T (MEMBER PATTERN (TAIL LIST))) + ) ) ) + (UNION . (LAMBDA (X Y) + (COND ((NULL X) Y) + ((MEMBER (HEAD X) Y) (UNION (TAIL X) Y)) + (T (CONS (HEAD X) (UNION (TAIL X) Y))) + ) ) ) + (INTERSECTION . (LAMBDA (X Y) + (COND ((NULL X) NIL) + ((MEMBER (HEAD X) Y) + (CONS (HEAD X) (INTERSECTION (TAIL + X) Y)) + ) + (T (INTERSECTION (TAIL X) Y)) + ) ) ) + ) + + +Die Funktion DEFINE, liefert als Pseudofunktion nicht nur einen LISP-Ausdruck als +Ergebnis, sondern hat auch einen bleibenden Effekt, nämlich eine Veränderung im +LISP-Heap. + +DEFINE hat beliebig viele Parameter der Form (Name . Funktion) und bewirkt, daß die +Funktionen unter dem jeweiligen Namen im System verfügbar werden, also für die +weitere Programmausführung definiert werden. Das Ergebnis von DEFINE ist eine +Liste der neuen Funktionsnamen, also hier + + + (MEMBER UNION INTERSECTION) + + +Der Wert den der LISP-Interpreter bei Eingabe von + + + (intersection (a1 a2 a3) (a1 a3 a5)) + + +liefert ist (A1 A3) , + + +Die Funktion + + + (union (x y z) (u v w x)) + + +liefert (Y Z U V W X) . + + + +Es folgen einige elementare Regeln für LISP-Programme: + +1. Ein LISP-Programm besteht aus einem Funktionsaufruf. Im Beispiel ist das die + Funktion DEFINE, die ihre Parameter (beliebig viele) berechnet und ausgibt. Die + Berechnung der Parameter erfolgt dabei in der Reihenfolge der Parameter (norma + le LISP-Funktionen mit mehreren Parametern berechnen standardmäßig alle + Parameter, allerdings in irgendeiner Reihenfolge). + +2. LISP ist formatfrei, d.h. jedes Symbol kann in jeder Spalte stehen. Für die Bedeu + tung des Programms ist nur die Reihenfolge der Symbole maßgeblich. Zeilen + wechsel wird als Leerzeichen aufgefaßt. + +3. Atome müssen mit einem Buchstaben anfangen, damit sie nicht mit Zahlen ver + wechselt werden. + +4. Ein LISP-Ausdruck der Form (A B C . D) ist eine Abkürzung für (A.(B.(C.D))). + Jede andere Plazierung des Punkts ist ein Fehler (falsch wäre z.B. (A . B C) ). + +5. Eine Anzahl von Basisfuntionen existiert von Anfang an, ohne daß sie durch + DEFINE eingeführt wurden. Der Programmierer kann weitere Funktionen bleibend + oder für die Dauer eines Programmlaufs einführen; dabei ist die Reihenfolge der + neuen Funktionen gleichgültig. +#page# + +2.3 Variablen#goalpage("p2.3")# + + + +Eine Variable ist ein Symbol, das ein Argument einer Funktion repräsentiert. Man +kann also schreiben: "a + b, wobei a = 3 und b = 4". In dieser Situation ist keine +Verwechslung möglich, so daß klar ist, daß das Ergebnis 7 ist. Um zu diesem Ergeb +nis zu kommen, muß man die Zahlen anstelle der Variablen einsetzen und die Opera +tion ausführen, d.h. die Zahlen addieren. + +Ein Grund, weshalb das eindeutig ist, liegt darin, daß "a" und "b" nicht "direkt" +addiert werden können, so daß etwa "ab" entsteht. In LISP kann die Situation viel +komplizierter sein. Ein Atom kann eine Variable oder ein Atom sein. + +Sollte der zukünftige LISP-Benutzer an dieser Stelle entmutigt sein, sei ihm gesagt, +daß hier nichts Neues eingeführt wird. Dieser Abschnitt ist nur eine Wiederholung der +Überlegungen aus Abschnitt 1.4. Alles, was wir in diesem Abschnitt sagen, kann man +aus den Regeln für LISP-Ausdrücke oder aus der allgemeinen Funktion "evalquote" +ableiten. + +Der Formalismus, der in LISP die Variablen kennzeichnet, ist die Lambdanotation von +Church. Der Teil des Interpreters, der die Variablen an Werte bindet, heißt "apply". +Wenn "apply" auf eine Funktion stößt, die mit LAMBDA anfängt, wird die Variablenli +ste (Argumentliste) mit der Parameterliste gepaart und am Anfang der Bindeliste +eingefügt. + +Während der Berechnung des Funktionsrumpfs müssen manchmal Variablen durch +ihre Werte ersetzt werden. Das geschieht dadurch, daß ihr Wert in der Bindeliste +nachgesehen wird. Wenn eine Variable mehrmals gebunden wurde, wird die zuletzt +etablierte Bindung verwendet. Der Teil des Interpreters, der diese "Berechnungen" +und die Berechnung von Funktionsaufrufen durchführt, heißt "eval". + + + +#page# + +2.4 Konstanten#goalpage("p2.4")# + + + +Manchmal heißt es, eine Konstante stehe für sich selbst, im Gegensatz zu einer +Variablen, die für etwas anderes, nämlich ihren Wert, steht. +Dies Konzept funktioniert in LISP nicht so ohne weiteres; es ist hier sinnvoller, zu +sagen, eine Variable ist konstanter als die andere, wenn sie in einer höheren Ebene +gebunden ist und ihren Wert seltener ändert. +In LISP bleibt eine Variable im Bereich des LAMBDA konstant, von dem sie gebunden +ist. Wenn eine Variable einen festen Wert hat, unabhängig davon, was in der Bindeli +ste steht, wird sie (echte) Konstante genannt. Dies wird mit Hilfe der Eigenschaftsliste +(E-Liste) des Atoms erreicht. +Jedes Atom hat eine E-Liste, in der Paare von Atomen und beliebigen Strukturen +gespeichert sind. Ein Atom hat die Eigenschaft A, wenn in seiner E-Liste ein Paar +mit dem Atom A enthält; die dazugehörige "beliebige Struktur" heißt Wert dieser +Eigenschaft. +Wenn ein Atom die Eigenschaft APVAL besitzt, ist es eine Konstante, deren Wert der +Wert der Eigenschaft ist. +Konstanten können durch die Pseudofunktion + + + (set atom wert) + + +gesetzt werden; nach der Auswertung eines solchen Aufrufs hat das Atom "atom" +immer den Wert "wert" - bis zum nächsten "set". Eine interessante Klasse von +Konstanten sind solche Konstanten, die sich selbst als Wert haben. Ein Beispiel dafür +ist NIL. Der Wert dieser Konstanten ist wieder NIL. Daher kann NIL nicht als Variable +benutzt werden, da es ja eine Konstante ist. (T und F gehören ebenfalls zu dieser +Klasse). + +#page# + +2.5 Funktionen#goalpage("p2.5")# + + + +Wenn ein LISP-Ausdruck für eine Funktion steht, ist die Situation ähnlich der, in der +ein Atom für einen Wert steht. Wenn die Funktion rekursiv ist, muß sie einen Namen +bekommen. Das geht mit einem LABEL-Ausdruck, der den Namen mit der Funk +tionsdefinition in der Bindeliste paart. Dadurch wird der Name an die Funktionsdefini +tion gebunden, so wie eine Variable an ihren Wert gebunden wird. In der Praxis setzt +man LABEL selten ein. Normalerweise ist es einfacher, Name und Definition wie bei +den Konstanten zu verknüpfen. Dies geschieht mit der Pseudofunktion DEFINE, die +wir am Anfang des Kapitels benutzt haben. +Diese Funktion kann beliebig viele Parameter der Form + + + (atom . funktion) + + +haben, wobei "atom" der Name der zu definierenden Funktion "funktion" werden soll. +Sie bewirkt, daß die Definition unter der Eigenschaft FUNCTION in der E-Liste des +Atoms abgelegt wird. +#page# + +3. Erweitertes LISP#goalpage("p3")# + + +In diesem Kapitel werden wir einige Erweiterungen zum reinen LISP einführen. Zu +diesen Erweiterungen gehören Möglichkeiten für Arithmetik, Zeichenkettenverarbei +tung, Funktionen, die spezielle Argumente erwarten, und Ein- und Ausgabe. + +In allen Fällen handelt es sich bei den Erweiterungen um zusätzliche Funktionen. So +heißt das Kommando für die Ausgabe eines LISP-Ausdrucks PUT. Syntaktisch ist +PUT nichts anderes als eine Funktion mit einem Argument. Sie kann mit anderen +Funktionen verkettet werden, und diese Verkettung wird ganz auf die übliche Art +behandelt, zuerst Berechnung der innern, dann der äußeren Funktionsaufrufe. Ein +Ergebnis ist nur in dem trivialen Sinn vorhanden, daß PUT sein Argument wieder +liefert, also die Identität ist. + +Funktionen, die eine Aktion wie Ein- oder Ausgabe bewirken, oder die Langzeitwir +kung (gesehen auf die Ausführungsdauer des Programms) haben, wie DEFINE und +SET, heißen Pseudofunktionen. Es ist eine Besonderheit von LISP, daß alle Funktio +nen einschließlich den Pseudofunktionen ein Ergebnis haben müssen. In einigen +Fällen ist das Ergebnis trivial und kann ignoriert werden. + +In diesem Kapitel beschreiben wir verschiedene Erweiterungen der Sprache LISP, die +im System fest enthalten sind. + + +#page# + +3.1 Gequotete Parameter #goalpage("p3.1")# + + + +Bevor ein Argument an eine Funktion übergeben wird, wird erst sein Wert in der +Bindeliste nachgesehen, d.h. es wird nicht der Name der Variablen übergeben, son +dern ihr Wert. Wenn das Argument als Konstante behandelt werden soll, muß es +ge"quotet" werden, d.h. statt "argument" steht (quote argument). Wenn ein Argument +einer Funktion immer als Konstante behandelt werden soll, ist es bequemer, das +Argument nicht jedesmal zu quoten. Das EUMEL-LISP-System erlaubt, in diesem +Fall den formalen Parameter in der Funktionsdefinition bereits zu quoten. + +Dieser Mechanismus wurde auch benutzt, um QUOTE zu implementieren; die Funk +tion lautet + + + quote = (lambda ((QUOTE x)) x) + + + + +#page# + +3.2 Funktionen mit beliebig vielen + Argumenten #goalpage("p3.2")# + + + +Ein Beispiel ist "list", das beliebig viele Argumente haben kann, die zu einer Liste +zusammengefaßt werden. Da eine Funktion nur eine feste Anzahl von Parametern +haben kann, eine Funktion mit beliebig vielen Argumenten aber gewiß keine feste +Anzahl von Argumenten hat, werden die beliebig vielen Argumente zu einer Liste +zusammengefaßt und ein einziger Parameter wird an diese Liste gebunden. Da "list" +genau diese Liste liefern soll, wird diese Funktion ebenfalls zu einer "Identität": + + + list = (lambda ((INDEFINITE x)) x) + + +Solche Parameter werden durch INDEFINITE gekennzeichnet. Sie können auch ge +quotet werden, indem man (INDEFINITE QUOTE parameter) schreibt; das wirkt so, als +wären alle Argumente, die diesem Parameter zugeordnet werden, einzeln gequotet +worden. + + + evalquote = (lambda (fkt (INDEFINITE QUOTE expr)) + (apply fkt expr NIL) ) + + + +#page# + +3.3 Funktionale Parameter #goalpage("p3.3")# + + + +In der Mathematik gibt es Funktionen, die andere Funktionen als Argument haben. In +der Algebra könnte man die Funktion "(operation operator a b)" definieren, wobei +"operator" ein funktionales Argument ist, das die Operation festlegt, die auf "a" und +"b" ausgeführt werden soll. Beispielsweise gilt + + + operation (+ 3 4) = 7 + operation (* 3 4) = 12 + + +In LISP sind funktionale Argumente sehr nützlich. Eine wichtige Funktion mit einem +Argument ist MAPLIST. Ihre Definition ist + + + (LAMBDA (LIST (FUNCTION FN)) + (COND ((NULL LIST) NIL) + (T (CONS (FN (HEAD LIST)) (MAPLIST (TAIL LIST) FN))) + ) ) + + +Diese Funktion nimmt eine Liste und eine Funktion als Argument und wendet die +Funktion auf die Listenelemente an. + + +#page# + +3.4 Prädikate und boolesche Konstanten #goalpage("p3.4")# + + + +Die booleschen Werte sind, wie in Kapitel 1 gesagt, T und F. Bei LISP-Ausdrücken +müßte daraus (quote T) und (quote F) werden, aber da die APVALs dieser Atome +wieder den Wert T und F haben, ist das quoten nicht nötig. + +Prädikate sind Funktionen, die T oder F als Ergebnis haben; es gibt also keine forma +len Unterschiede zwischen anderen Funktionen und Prädikaten. + +Daher ist es durchaus möglich, daß eine Funktion einen Wert liefert, der weder T +noch F ist, daß aber durch einen bedingten Ausdruck an dieser Stelle ein boolescher +Ausdruck verlangt wird. In diesem Fall ist die Wirkung des Ausdrucks nicht definiert. + +Das Prädikat EQ hat folgendes Verhalten: +1. Wenn seine Argumente verschieden sind, ist das Ergebnis F. +2. Wenn die Argumente dasselbe Atom sind, ist das Ergebnis T. +3. Wenn die Argumente gleich, aber nicht atomar sind, ist das Ergebnis T oder F, je + nachdem, ob sie ein und dasselbe Objekt im Heap sind oder nicht. + +#page# + +3.5 Unbenannte Atome #goalpage("p3.5")# + + + +Die meisten Atome im EUMEL-LISP haben einen Namen, der sie bei Ein- und +Ausgabeoperationen identifiziert. +Es gibt aber auch Atome, die keinen Namen haben und stattdessen durch ihre Werte +repräsentiert werden. Momentan sind das Ganzzahlen und Zeichenketten (TEXTe); +auch die booleschen Werte kann man in einem weiteren Sinn dazurechnen. + + + + +3.5.1 Ganzzahlen + + + +Im EUMEL-LISP gibt es Funktionen, die Basisoperationen und Tests durchführen. + +Ganzzahlen haben folgende Eigenschaften: + +1. Eine Ganzzahl besteht aus einem optionalen Vorzeichen und einer Folge von + Ziffern; zwischen Vorzeichen und Ziffern können Leerzeichen stehen. +2. Der Wert einer Ganzzahl liegt zwischen -32768 und 32767 (minint und maxint). +3. Eine Ganzzahl kann überall dort stehen, wo ein Atom stehen kann, außer als + Parameter. +4. Ganzzahlen sind Konstanten; sie brauchen also nicht gequotet werden. +#page# + +3.5.2 Arithmetische Funktionen und Prädikate + + + +Es folgt eine Liste aller arithmetischen Funktionen. +Wenn ein Argument einer dieser Zahlen keine Ganzzahl ist, erfolgt eine Fehlermel +dung. + + (sum x1 ... xn) liefert die Summe der xi; wenn keine Argumente gege + ben werden, wird 0 geliefert. + (difference x y) liefert die Differenz von x und y. + (product x1 ... xn) liefert das Produkt seiner Argumente; wenn + keine Argumente gegeben werden, wird 1 + geliefert. + (quotient x y) liefert den Quotienten von x und y, ohne den + Rest zu berücksichtigen. + (remainder x y) liefert den Rest der Division von x und y. + (getint) liest eine Zahl vom Bildschirm ein und + liefert sie. + (putint x) gibt x auf den Bildschirm aus. Identitäts funktion. + + + + + +3.5.3 Zeichenkettenverarbeitung + + + +Im Moment ist nur Zeichenketten-Ein- und Ausgabe implementiert. +Die Ausgabe löst bei Argumenten, die keine Zeichenketten sind, eine Fehlermeldung +aus. + + (gettext) liest eine Zeichenkette ein und liefert sie. + (puttext x) gibt eine Zeichenkette aus. + + + + +3.5.4 Test auf Gleichheit + + + + (equal x y) testet, ob x und y vom gleichen Typ sind, und wenn ja, ob sie gleich + sind. +#page# + +3.6 Aufruf von EUMEL aus #goalpage("p3.6")# + + +Bevor man den LISP-Interpreter benutzen kann, muß er folgendermaßen implemen +tiert werden: + +archive ("lisp") +fetch all (archive) +release (archive) +check off +insert ("lisp.1") +insert ("lisp.2") +insert ("lisp.3") +insert ("lisp.4") +check on + + +Das LISP-System verfügt über einen Heap, in dem alle LISP-Ausdrücke gespei +chert sind. Standardmäßig enthält der Heap eine Reihe von Funktionen, die nicht in +den LISP-Programmen definiert werden müssen (Übersichten über die Standardfunk +tionen siehe Kapitel 3.5). + +Mit + lisp + +wird das LISP-System im EUMEL-Dialog gestartet. In einem Eingabefenster wird +mit Hilfe des Paralleleditors eine LISP-EINGABE-Möglichkeit angeboten. Die Aus +gabe erfolgt in dem LISP-AUSGABE-Fenster. +Das LISP-System kann folgendermaßen verlassen werden: +<ESC> <ESC> break lisp <RETURN>. + +Statt dieser direkten Art der Benutzung der LISP-Maschine ist auch eine an ELAN +angelehnte Art mit den Prozeduren "run lisp", insert lisp" usw. vorgesehen: + +Mit + + run lisp (TEXT CONST dateiname) + +wird eine Kopie des Heaps angelegt, das Programm aus der Datei "dateiname" in die +Kopie eingelesen und gestartet. Durch diesen Kopiermechanismus wird der Original +heap vor Zusammenbrüchen des LISP-Systems geschützt. + + insert lisp (TEXT CONST dateiname) + +bewirkt dasselbe wie "run lisp"; allerdings wird jetzt direkt auf dem Originalheap +gearbeitet. Dadurch sind alle Änderungen im Heap, die das Programm verursacht +(meist Definition von Funktionen durch DEFINE) bleibend, aber auch ein Zusammen +bruch ist insoweit endgültig, als das LISP-System jetzt neu gestartet werden muß. +Das geschieht mit + + start lisp system (DATASPACE CONST dsname) + +"dsname" gibt dabei den Datenraum an, der die zum Hochfahren notwendigen Daten +enthält. Solche Daten im richtigen Format enthält der Datenraum "lisp.bootstrap". +Wenn der zuletzt benutzte Heap mit nicht mehr durch LISP-Programme erreich +bare Strukturen vollgestopft ist, schafft die Prozedur + + collect lisp heap garbage + +Abhilfe; mit + + lisp storage info + +kann man den Erfolg kontrollieren. +#page# + +4. Detailbeschreibungen#goalpage("p4")# + + + + + +4.1 Grundfunktionen #goalpage("p4.1")# + + + +Die Datei "lisp.1" enthält ein Paket, das die Grundlage des LISP-Systems bildet. Es +implementiert + + - die primitiven LISP-Funktionen wie "cons", "null", etc., + - die Verwaltung des Heaps, in dem die LISP-Strukturen und die Objektliste + (Oblist) gespeichert sind, + - einen Datentyp SYM, dessen Wertevorrat aus Zeigern auf die im Heap gespei + cherten Strukturen besteht, + - Funktionen zur Konversion allgemeiner Daten in LISP-Strukturen (bisher reali + siert: TEXT <--> SYM und INT <--> SYM). + +Durch die Implementation der Basisoperationen als exportierte und damit allgemein +verfügbare ELAN-Prozeduren ist es möglich, LISP-Strukturen durch ELAN-Prog +ramme zu manipulieren; insbesonders können ELAN- und LISP-Programme über +diese Strukturen miteinander kommunizieren. + +Anmerkung: +Wenn Eigenschaften von "SYM"-Objekten beschrieben werden, sind immer die +Eigenschaften der Strukturen gemeint, auf die die Objekte zeigen, wenn nichts ande +res angegeben wird. + + +Es werden folgende Prozeduren exportiert: + + PROC initialize lisp system (DATASPACE CONST new heap): + "new heap" ist der neue Datenraum, in dem der LISP-Heap ab sofort geführt + wird. + Vorsicht: Beim Wechsel zu einem neuen Datenraum sind die Werte der + SYM-Variablen, die auf Strukturen im alten Heap zeigen, natürlich wertlos! + + PROC dump lisp heap (FILE VAR f): + In "f" wird ein Dump des Heaps erstellt. Dieser Dump ist nur mit Kenntnis des + Programmtextes aus "lisp 1" verständlich; er wird hier nicht beschrieben. + + PROC lisp storage (INT VAR size, used): + Nach dem Aufruf gibt "size" die maximal verfügbare Anzahl von Knoten an, + während "used" die Anzahl der tatsächlich von LISP-Strukturen belegten + Knoten enthält. Zu diesen Strukturen können auch solche zählen, die nicht mehr + durch "head" oder "tail" etc. erreichbar sind. + + PROC collect lisp heap garbage: + Löscht die im LISP-Heap nicht mehr durch "atom (TEXT CONST)", "proper + ty", "head" und "tail" erreichbaren Strukturen. Es werden auch alle nur von + ELAN-Programmen aus über SYM-Variable erreichbare Strukturen gelöscht, so + daß die Werte dieser Variablen undefiniert werden. + Die Müllabfuhr wird von keiner Prozedur dieses Pakets aufgerufen, d.h. der + Benutzer, der ELAN-Programme einsetzt, braucht nicht alle Strukturen in den + Eigenschaftslisten von Atomen aufzubauen, um sie vor einer versehentlichen + Löschung durch die Müllabfuhr zu schützen, vorausgesetzt, er ruft sie nicht + selbst auf. Er muß allerdings darauf achten, daß im Heap noch genug Platz + bleibt. + + OP := (SYM VAR left, SYM CONST right): + Nach der Zuweisung zeigt "left" auf die gleiche Struktur wie vorher "right". + + SYM CONST nil, pname; + Zwei Konstanten, die dem LISP-System ständig zur Verfügung stehen müs + sen. Ihre Drucknamen sind "NIL" bzw. "PNAME" (vgl. Schlußbemerkungen) + + SYM PROC head (SYM CONST sym): + Entspricht der im Handbuch beschriebenen Funktion "head". + + SYM PROC tail (SYM CONST sym): + Entspricht der im Handbuch beschriebenen Funktion "tail". + + SYM PROC cons (SYM CONST head, tail): + Liefert einen SYM-Wert "zeiger" auf eine neue Struktur. Es gilt: + head ("zeiger") = "head" und tail ("zeiger") = "tail". + + BOOL PROC eq (SYM CONST sym 1, sym 2): + Prüft, ob "sym 1" und "sym 2" auf dieselbe Struktur zeigen. Das ist genau dann + der Fall, wenn sie durch Zuweisung auseinander hervorgegangen sind oder wenn + sie auf das gleiche benannte Atom zeigen. + + BOOL PROC equal (SYM CONST sym 1, sym 2): + Prüft, ob "sym 1" und "sym 2" dieselbe Struktur haben; "dieselbe Struktur" + braucht aber nicht "Identität" zu bedeuten, wie "eq" das verlangt. + Umgewandelte TEXTe und INTs werden richtig verglichen (siehe "sym (INT + CONST)" und "sym (TEXT CONST)"). + + BOOL PROC null (SYM CONST sym): + Prüft, ob "sym" gleich der Konstanten "NIL" ist (entspricht + eq ("sym", "NIL"), ist aber schneller). + + BOOL PROC atom (SYM CONST sym): + Prüft, ob "sym" ein ( benanntes oder unbenanntes) Atom ist. + + BOOL PROC is named atom (SYM CONST sym): + Prüft, ob "sym" ein benanntes Atom ist. + + PROC begin oblist dump: + Vorbereitung für "next atom". + + SYM PROC next atom: + Liefert das nächste Atom aus der Objektliste. In der Objektliste sind alle benann + ten Atome, die der Heap enthält, aufgeführt (bis auf Ausnahmen; s."delete + atom"). "NIL" wird immer als letzte Atom geliefert. + + SYM PROC atom (TEXT CONST name): + Liefert einen Zeiger auf das Atom mit dem Namen "name". Wenn kein solches + Atom in der Objektliste vorhanden ist, wird "NIL" geliefert. + + SYM PROC new atom (TEXT CONST name): + Liefert einen Zeiger auf das Atom mit dem Namen "name". Wenn kein solches + Atom in der Objektliste vorhanden ist, wird ein neues mit diesem Namen in sie + eingefügt. + + PROC create atom (TEXT CONST name): + Fügt ein Atom mit dem Namen "name" in die Objektliste ein. Wenn ein solches + Atom bereits existiert, wird stattdessen eine Fehlermeldung ausgegeben. + + PROC delete atom (SYM CONST atom): + Streicht das Atom "atom" aus der Objektliste. + + PROC begin property list dump (SYM CONST atom): + Vorbereitung für "next property". + + PROC next property (SYM VAR property id, property): + Liefert die nächste Eigenschaft aus der Eigenschaftsliste des zuletzt durch + "begin property list dump" vorbereiteten Atoms. Wenn es sich bei der Eigen + schaft um eine Flagge handelt, wird "property" auf "NIL" gesetzt; wenn es keine + nächste Eigenschaft mehr gibt, werden "property" und "property id" auf "NIL" + gesetzt. + Der Dump der Eigenschaftsliste beeinträchtigt die "Verwendbarkeit" des Atoms in + keiner Weise; es ist während des Dumps sogar möglich, Eigenschaften und + Flaggen zu lesen. Wenn während des Dumps Eigenschaften oder Flaggen geän + dert oder geschrieben werden, ist mit fehlerhaften Dumpergebnissen zu rechnen. + + PROC add property (SYM CONST atom, property id, property): + "property id" muß ein benanntes Atom sein. Führt eine neue Eigenschaft mit der + Bezeichnung "property id" und dem Wert "property" ein. Wenn bereits eine + Eigenschaft mit der gleichen Bezeichnung existiert, wird die alte Version über + deckt, ist aber weiter vorhanden. + + PROC alter property (SYM CONST atom, property id, property): + Bringt die Eigenschaft mit der Bezeichnung "property id" auf den neuen Wert + "property". Wenn eine Eigenschaft mit dieser Bezeichnung noch nicht existiert, + wird eine Fehlermeldung ausgegeben. + + BOOL PROC property exists (SYM CONST atom, property id): + Prüft, ob das Atom eine Eigenschaft mit der Bezeichnung "property id" besitzt. + + SYM PROC property (SYM CONST atom, property id): + Liefert den Wert der gerade sichtbaren Eigenschaft des Atoms, die die Bezeich + nung "property id" hat. Falls die Eigenschaft nicht existiert, wird "NIL" geliefert. + + PROC delete property (SYM CONST atom, property id): + Löscht den gerade sichtbaren Wert der Eigenschaft des Atoms, die die Bezeich + nung "property id" hat. Wenn eine ältere Version dieser Eigenschaft durch "add + property" überdeckt wurde, wird diese jetzt wieder sichtbar. Jede Eigenschaft + bildet also für jedes Atom einen Stapel (Stack). + + PROC add flag (SYM CONST atom, flag id): + Das Atom "atom" erhält die Flagge "flag id". Ein Atom kann dieselbe Flagge + durchaus mehrmals haben. + + BOOL PROC flag (SYM CONST atom, flag id): + Prüft, ob "atom" mindestens eine Flagge "flag id" hat. + + PROC delete flag (SYM CONST atom, flag id): + Löscht eine Flagge "flag id" von "atom". Wenn keine Flagge existiert, wird + nichts getan. + + SYM PROC sym (TEXT CONST text): + Konvertiert "text" in ein unbenanntes Atom und liefert einen Zeiger auf dies + Atom. + + TEXT PROC text (SYM CONST sym): + Konvertiert "sym" in einen TEXT zurück, wenn es sich um einen konvertierten + TEXT handelt; wenn nicht, wird eine Fehlermeldung ausgegeben. + + BOOL PROC is text (SYM CONST sym): + Prüft, ob "sym" ein konvertierter TEXT ist. + + SYM PROC sym character (TEXT CONST text): + "text" muß genau ein Zeichen enthalten. Das Zeichen wird in ein + CHARACTER-Objekt im Heap konvertiert und ein Zeiger auf dies Objekt gelie + fert. + + INT PROC character (SYM CONST sym): + "sym" muß auf ein CHARACTER-Objekt zeigen. Geliefert wird der Code des + dort gespeicherten Zeichens. + + SYM PROC sym (INT CONST i 1, i 2): + Konvertiert "i 1" und "i 2" in ein unbenanntes Atom und liefert einen Zeiger + darauf. + + INT PROC int 1 (SYM CONST sym): + INT PROC int 2 (SYM CONST sym): + Holt die Werte der ersten bzw. zweiten Ganzzahl aus "sym", wenn es sich um + ein konvertiertes INT-Paar handelt; wenn nicht, wird eine Fehlermeldung ausge + geben. + + BOOL PROC is int pair (SYM CONST sym): + Prüft, ob "sym" ein konvertiertes INT-Paar ist. + + +Prozedurübergreifende Aussagen über das Paket "lisp.1": + + - Es gibt benannte und unbenannte Atome. + + - Die unbenannten Atome sind Konversionsprodukte. + + - Vor dem ersten Aufruf von "delete atom" sind alle benannten Atome in der Ob + jektliste enthalten; d.h. sie können alle durch "begin oblist dump" und wiederhol + ten Aufruf von "next atom" erreicht werden. + + - Jedes benannte Atom hat genau einen Namen, der immer gleich bleibt. Der + Name ist als Eigenschaft mit der Bezeichnung "pname" in der Eigenschaftsliste + gespeichert. "add property", "alter property" und "delete property" geben des + halb eine Fehlermeldung aus, statt ihre normalen Aktionen durchzuführen, wenn + ihnen als Eigenschaftsbezeichnung "pname" übergeben wird. + + - Es gibt keine zwei Atome, die denselben Namen haben; dadurch reduziert sich + die bei "eq" angegebene Fallunterscheidung auf einen Fall. + + - Es kann durchaus zwei unbenannte Atome mit gleichen Werten geben, die von + "eq" nicht als gleich anerkannt werden, weil sie in verschiedenen Strukturen + gespeichert sind. "equal" achtet nicht auf die Position, sondern auf die Werte + der zu vergleichenden Strukturen. + + - Mehrfache Zugriffe auf die gleiche Eigenschaft desselben Atoms werden so opti + miert, daß die Eigenschaftsliste nur beim ersten Zugriff (meist durch "property + exists") durchsucht werden muß. + + + +#page# + +4.2 Weitere Funktionen sowie Eingabe und + Ausgabe #goalpage("p4.2")# + + + +Die Datei "lisp.2" enthält diverse Pakete, die die Verbindung vom LISP-System zur +normalen EUMEL-Umgebung bilden. Momentan sind das Ein- und Ausgabe und +(exemplarisch) die fünf Grundrechenarten für Ganzzahlen. + +Die Ein- und Ausgabe von LISP-Strukturen wird durch das Paket namens "lisp io" +mit den folgenden Prozeduren ermöglicht: + + PROC get (FILE VAR f, SYM VAR sym): + Nach dem Aufruf zeigt "sym" auf eine neue aus "f" eingelesene Struktur. + In der ersten und hinter der letzten Zeile des S-Ausdrucks dürfen keine weiteren + Daten stehen. + + PROC get all (FILE VAR f, SYM VAR sym): + Wie "get (FILE V, SYM V)", nur daß die Datei nichts als den S-Ausdruck ent + halten darf. + + PROC get (SYM VAR sym): + Es wird mit "get all" ein S-Audruck von einer Scratch-Datei eingelesen, die + dem Benutzer vorher zum Editieren angeboten wird. Bei Einlesefehlern wird die + Datei zu Korrigieren angeboten, bis keine Fehler mehr auftreten. + + PROC put (FILE VAR f, SYM CONST sym): + Wenn "sym" ein Ganzzahlpaar ist, wird die erste Zahl ausgegeben; wenn es ein + konvertierter TEXT ist, wird der ursprüngliche TEXT wieder ausgegeben; bei + einem benannten Atom oder einer allgemeinen LISP-Struktur wird ein S-Aus + druck ausgegeben. + + PROC put (SYM CONST sym): + Wie "put (FILE V, SYM CONST), außer daß die Augabe direkt auf den Bildschirm + erfolgt. + + +Das Paket "lisp int" enthält die Prozeduren + + SYM PROC sum (SYM CONST summandenliste); + Erwartet eine Liste von "int pair"-Summanden und liefert deren Summe. + + SYM PROC difference (SYM CONST minuend, subtrahend): + Liefert die Differenz der Parameter. + + SYM PROC product (SYM CONST faktorenliste): + Liefert das Produkt der Listenelemente. + + SYM PROC quotient (SYM CONST dividend, divisor): + Liefert den Quotienten der Parameter. + + SYM PROC remainder (SYM CONST dividend, divisor): + Liefert den Rest. + +#page# + +4.3 Interpreter #goalpage("p4.3")# + + +Die Datei "lisp.3" enthält das Paket "lisp interpreter", das die Prozedur + + SYM PROC evalquote (SYM CONST expression) + +exportiert. Es handelt sich dabei um den im EUMEL-LISP-Handbuch beschriebe +nen Interpreter. + +Wenn "expression" ein LISP-Ausdruck ist, liefert die Prozedur den Wert des Aus +drucks (vorausgesetzt, der LISP-Heap ist vorbereitet, siehe lisp.1). + +Wirkungsweise: +"evalquote" ruft im Wesentlichen die Prozedur "eval" auf. +"eval" erwartet als Argumente einen solchen LISP-Ausdruck wie "evalquote", benö +tigt aber zusätzlich eine sog. Bindeliste. In einer Bindeliste sind durch LAMBDA- und +LABEL-Ausdrücke bereits gebundene Variable und ihre Werte gespeichert. Die +Manipulation der Bindeliste ist durch eine Reihe von Refinements, die am Schluß des +Pakets stehen, realisiert. + +Da bisher noch keine LAMBDA- oder LABEL-Ausdrücke verarbeitet wurden, über +gibt "evalquote" die leere Bindeliste. + +Wirkungsweise von + + SYM PROC eval (SYM CONST expression, association list): + +"eval" kann als erstes Argument ein Atom oder eine zusammengesetzte Struktur +erhalten. + +Atome werden als Variable aufgefaßt, deren Wert in der Bindeliste aufzusuchen ist. +Vor der Konsultation der Bindeliste wird allerdings noch nach der Eigenschaft APVAL +des Atoms gesehen; wenn sie vorhanden ist, handelt es sich um eine Konstante wie +NIL, T oder F, die einen festen Wert hat, nämlich den Wert dieser Eigenschaft. Da +diese Konstanten sich selbst als Wert haben, gilt "eval (NIL, Bindeliste) = NIL" +(entsprechend für "T" und "F"). + +Wenn das erste Arugment von "eval" zusammengesetzt ist, wird angenommen, daß +es sich um einen Funktionsaufruf der Form + + + +-----+-----+ + | o | o--+--> Argumentliste + +--+--+-----+ + | + V + Funktion + + +handelt. Die Bestandteile "Funktion" und "Argumentliste" werden mit der Bindeliste +übergeben an: + + SYM PROC apply (SYM CONST function, arguments, association list): + +"apply" hat die Aufgabe, die Argumente durch "eval" berechnen zu lassen (das +unterbleibt allerdings unter bestimmten Umständen) und die Berechnungergebnisse an +die Parameter der Funktion zu binden; zum Schluß muß der Wert des Funktions +rumpfs in Abhängigkeit von diesen neuen Bindungen als Ergebnis der gesamten +Prozedur "apply" berechnet werden; diese Berechnung geschieht wieder durch +"eval". + +Nur in einem LAMBDA-Ausdruck ist direkt bekannt, wo die Parameterliste steht.So +lange das nicht der Fall ist, muß entweder ein LABEL-Ausdruck oder ein Atom +vorliegen. +Ein LABEL-Ausdruck hat die Form + + + +-----+-----+ +-----+-----+ +-----+-----+ + | o | o--+--->| o | o--+--->| o | NIL | + +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | + V V V + LABEL Name Funktion + + +Da der Name für die Dauer der Auswertung des Funktionsrumpfs an die Funktion +gebunden sein muß, wird dis Paar als funktionaler Bindelisteneintrag gespeichert. +Funktionale und nichtfunktionale Bindelisteneinträge sind eindeutig unterschieden. + +Nach dem Abspeichern wird wieder getestet, ob die Funktion diesmal ein +LAMBDA-Ausdruck ist; wenn nicht, wird ein weiterer Schritt zum "Ablättern" von +LABELs und Atomen versucht, usw. + +Wenn die Funktion ein Atom ist, werden analog zu den Vorgängen in "eval" erst die +Eigenschaftsliste und dann die Bindeliste durchsucht. + +Ist die Eigenschaft FUNCTION in der Eigenschaftsliste vorhanden, ist der Wert der +Eigenschaft die (evtl. weiter "abzublätternde") Funktion; ist die Eigenschaft nicht +vorhanden, muß das Atom an eine Funktion gebunden sein, die dann aus der Binde +liste geholt werden kann. + +Da alle Funktionen (auch die Standardfunktionen) letztendlich als LAMBDA-Aus +drücke definiert sind, kommt "apply" auf diese Weise zuletzt zu einem LAMBDA- +Ausdruck. + +Ein LAMBDA-Ausdruck hat die Form + + + +-----+-----+ +-----+-----+ +-----+-----+ + | o | o--+--->| o | o--+--->| | | + +--+--+-----+ +--+--+-----+ +-----+-----+ + | | + V V + LAMBDA Parameterliste + + +Als nächster Schritt werden die Argumente für die zu berechnende Funktion an die +Parameter der Parameterliste gebunden, d.h. es werden Parameter-Argument-Paare +in die Bindeliste eingetragen. + +Die Methode des Eintrags ist je nach Art des Parameters unterschiedlich. Es gibt die +folgenden Arten von Parametern: + + + 1. | + | + V + Name + + + "Name" ist hier - wie bei den restlichen Fällen - der Name des Parame + ters. Diese Art von Parametern ist der Normalfall; die Argumente, die einem + solchen Parameter entsprechen, werden durch "eval" berechnet und zusammen + mit dem Parameter in einem Bindelisteneintrag gespeichert. + + + 2. | + | + V + +-----+-----+ +-----+-----+ + | o | o--+--->| o | NIL + + +--+--+-----+ +--+--+-----+ + | | + V V + QUOTE Name + + + In diesem Fall wird das Argument ohne weitere Verarbeitung in die Bindeliste + übernommen. Die Wirkung ist die gleiche, als wäre das Argument durch + "(QUOTE ... )" eingeschlossen. + + + 3. | + | + V + +-----+-----+ +-----+-----+ + | o | o--+--->| o | NIL | + +--+--+-----+ +--+--+-----+ + | | + V V + FUNCTION Name + + + Hier wird ein funktionaler Bindelisteneintrag erzeugt, so daß "Name" im Funk + tionsrumpf als Name einer Funktion auftreten kann. + + + 4. | + | + V + +-----+-----+ +-----+-----+ + | o | o--+--->| o | NIL | + +--+--+-----+ +--+--+-----+ + | | + V V + INDEFINITE Name + + + Dies ist ein Parameter, der beliebig viele berechnete Argumente aufnehmen + kann. Der Einfachheit halber werden die Ergebnisse zu einer Liste zusammen + gefaßt und mit "Name" in einen Bindelisteneintrag gesteckt. + + + 5. | + | + V + +-----+-----+ +-----+-----+ +-----+-----+ + | o | o--+--->| o | o--+--->| o | NIL | + +--+--+-----+ +--+--+-----+ +--+--+-----+ + | | | + V V V + INDEFINITE QUOTE Name + + + Dieser Parameter kann wie der in Fall 4. aufgeführte beliebig viele Argumente + aufnehmen, die zu einer Liste zusammengefaßt werden. Im Gegensatz zu 4. + wird aber wie bei 2. nichts durch "eval" berechnet, sondern die Argumente so + wie sie vorkommen übernommen. + +Auf einen Parameter der Form 4. oder 5. darf kein weiterer Parameter folgen, weil +solch ein Parameter alle restlichen Argumente verbraucht. Solchen Parametern darf - +als Ausnahme - auch kein Argument entsprechen; dann werden sie an die leere +Liste (d.h. NIL) gebunden. + +Der letzte Kasten in der Beschreibung des LAMBDA-Ausdrucks ist mit Absicht leer +geblieben; er kann eine der Formen + + + +-----+-----+ +----------+----------+ + | o | NIL | oder | Ganzzahl | XXXXXXXX | + +--+--+-----+ +----------+----------+ + | + V + Funktionsrumpf + + +annehmen. + +Die erste Form heißt, daß die Funktion durch Berechnung des Funktionsrumpfs mittels +"eval" berechnet werden soll; die zweite Form bewirkt den Aufruf einer der Standard +funktionen, je nachdem, welche Funktionsnummer bei "Ganzzahl" steht. In diesem +zweiten Fall werden die Argumente aber nicht durch den Namen des Parameters +identifiziert, sondern durch die Position des Eintrags in der Bindeliste. Dieser Pro +grammteil hängt also wesentlich von der Reihenfolge ab, in der die Bindelisteneinträ +ge, die bei der Parameter-Argument-Zuordnung entstehen, in die Bindeliste einge +fügt werden. Zur Zeit ist das die Umkehrung der Reihenfolge der Parameter. + +Die Namen der Refinements "arg 1", "arg 2", "arg 3" beziehen sich auch nicht auf +die Position des Arguments in der Argumentsliste, sondern auf die Position des +Eintrags in der Bindeliste. + +#page# + +4.4 Kommandoprozeduren #goalpage("p4.4")# + + + +Die Datei "lisp.4" enthält eine Reihe von Prozeduren, mit denen der LISP-Interpre +ter ähnlich wie der ELAN-Compiler aufgerufen werden kann. + +Die Prozedur + + start lisp system + +ermöglicht das erneute Starten des LISP-Systems, oder wenn "übersetzte" Pro +gramme, die in einem Heap einer anderen Task liegen, in dieser Task verarbeitet +werden sollen. + +Die Prozedur + + lisp + +stellt die LISP-Maschine in einem Doppelfenster im Bildschirmdialog zur Verfügung. +Bei der erstmaligen Benutzung muß die Datei "lisp.bootstrap" vorhanden sein. + +Die Prozedur + + break lisp + +koppelt die LISP-Task vom Benutzer-Terminal ab und baut das Doppelfenster für +den Bildschirmdialog neu auf. + + +Die Prozedur + + run lisp + +bewirkt, daß ein LISP-Programm eingelesen und ausgeführt wird; nach der Ausfüh +rung wird das Ergebnis der Berechnung ausgegeben. Diese Operationen werden auf +einer Kopie des Heaps ausgeführt, so daß Änderungen keine Dauerwirkung haben. +Mit + + run lisp again + +wird das zuletzt eingelesene Programm noch einmal gestartet; da dafür die gleiche +Kopie des Heaps wie bei "run" benutzt wird, kann das Ergebnis diesmal anders sein. + + insert lisp + +wirkt wie "run lisp", außer daß diesmal alle Änderungen, die durch das Einlesen und +Ausführen im Heap entstehen, dauerhaft sind. + + + PROC start lisp system (DATASPACE CONST heap): + Eine Kopie von "heap" wird der neue LISP-Heap. Wenn es sich um "nilspa + ce" handelt, werden einige organisatorische Strukturen im Heap aufgebaut und + die Atome "NIL" und "PNAME" erzeugt. + + PROC start lisp system (DATASPACE CONST heap, FILE VAR f): + Zunächst wird "start lisp system (heap)" gegeben. + Danach werden die Eigenschaftsbeschreibungen aus "f" in Strukturen im Heap + umgesetzt. + + Jede Beschreibung in "f" muß mit dem Zeilenanfang beginnen und kann sich + über mehrere Zeilen erstrecken. Jede Beschreibung besteht aus den Elementen + <Atom> <Eigenschaft> <Wert> + wobei <Eigenschaft> der Name einer Eigenschaft (i.a. APVAL oder FUNCTION) + und <Wert> ein beliebiger S-Ausdruck sein müssen. Die drei Elemente müs + sen jeweils durch mindestens ein Leerzeichen getrennt sein. + + Wenn das Atom <Atom> nicht existiert, wird es erzeugt; danach wird <Wert> + unter <Eigenschaft> in der Eigenschaftsliste eingetragen. + + Wenn <Eigenschaft> NIL ist, muß <Wert> wegfallen; dann wird nichts in die + Eigenschaftsliste eingetragen. + + DATASPACE PROC lisp heap: + Liefert den LISP-Heap. Das ist manchmal für Sicherheitskopien etc. nützlich. + Die durch "run lisp" erzeugten Kopien sind nicht zugänglich. + + PROC run lisp: + Ruft "run lisp (last param)" auf. + + PROC run lisp (TEXT CONST file name): + Das in der Datei "file name" stehende LISP-Programm (d.h. der dort stehende + in einen S-Ausdruck übersetzte M-Ausdruck) wird in eine neue Kopie des + LISP-Heaps eingelesen und ausgeführt. Evtl. vorher durch "run lisp" erzeugte + Kopien des Heaps werden vorher gelöscht. + + Wenn das Programm syntaktisch nicht korrekt ist, wird es im Paralleleditor zur + Korrektur angeboten. + + PROC run lisp again: + Führt das zuletzt eingelesene Programm noch einmal im gleichen Heap aus. + + PROC insert lisp: + Ruft "insert lisp (last param)" auf. + + PROC insert lisp (TEXT CONST file name): + Wirkt wie "run lisp (file name)", nur daß alle Operationen auf dem Originalheap + ausgeführt werden. Auch "run lisp again" wirkt nun nicht mehr auf der Kopie. + diff --git a/lang/lisp/1.8.7/source-disk b/lang/lisp/1.8.7/source-disk new file mode 100644 index 0000000..e61107d --- /dev/null +++ b/lang/lisp/1.8.7/source-disk @@ -0,0 +1 @@ +informatikpaket/01_sprachen.img diff --git a/lang/lisp/1.8.7/src/"15"TAB2"14" b/lang/lisp/1.8.7/src/"15"TAB2"14" Binary files differnew file mode 100644 index 0000000..654b374 --- /dev/null +++ b/lang/lisp/1.8.7/src/"15"TAB2"14" diff --git a/lang/lisp/1.8.7/src/lisp.1 b/lang/lisp/1.8.7/src/lisp.1 new file mode 100644 index 0000000..32a9c27 --- /dev/null +++ b/lang/lisp/1.8.7/src/lisp.1 @@ -0,0 +1,1306 @@ +PACKET lisp heap and oblist management (* Autor: J.Durchholz *) + (* Datum: 09.05.1984 *) + DEFINES (* Version 1.7.2 *) + (* hey 25.2.83 *) + initialize lisp system, + dump lisp heap, + lisp storage, + collect lisp heap garbage, + SYM, + :=, + nil, + pname, + head, + set head, + tail, + set tail, + cons, + eq, + equal, + null, + atom, + is named atom, + begin oblist dump, + next atom, + new atom, + create atom, + delete atom, + begin property list dump, + next property, + add property, + alter property, + property, + delete property, + property exists, + add flag, + flag, + delete flag, + text, + is text, + character, + is character, + sym character, + int 1, + int 2, + is int pair, + sym: + + +(* NOTE: All internal routines are prefixed by x *) + + +(***************************** heap management ****************************) + +LET + max size = 32767, + NODE = STRUCT (INT status, + head, tail); +LET HEAP = STRUCT (INT size, + ROW max size NODE node); + + +BOUND HEAP VAR heap; + + +PROC initialize lisp system (DATASPACE CONST ds): + IF type (ds) < 0 THEN + heap := ds; + x initialize oblist and heap size; + create atom ("NIL"); + create atom ("PNAME"); + ELSE + heap := ds + FI +END PROC initialize lisp system; + + +PROC dump lisp heap (FILE VAR f): + put line (f, "Groesse :" + text (CONCR (heap).size)); + line (f); + put (CONCR (heap).size); + BOOL VAR is char := FALSE; + INT VAR i; + FOR i FROM 1 UPTO CONCR (heap).size REP + cout (i); + dump ith node + PER. + +dump ith node: + put (f, text (i, 6)); + put (f, status); + put (f, head); + put (f, tail); + line (f). + +status: + SELECT ith node.status OF + CASE atomic : "ATOMIC............" + CASE non atomic : "NON ATOMIC........" + CASE oblist bone : "OBLIST BONE......." + CASE property indicator : "PROPERTY INDICATOR" + CASE property root : "PROPERTY ROOT....." + CASE flag indicator : "FLAG INDICATOR...." + CASE text data : "TEXT DATA........." + CASE character data : is char := TRUE; "CHARACTER DATA...." + CASE int data : "INT DATA.........." + OTHERWISE "????." + text (ith node.status, 6) + ".????" + END SELECT. + +head: + maybe a code + text (ith node.head, 6). + +maybe a code: + IF is char THEN + is char := FALSE; + IF ith node.head > 31 AND 128 > ith node.head THEN + " " + code (ith node.head) + " " + ELSE + " " + FI + ELSE + " " + FI. + +tail: + text (ith node.tail, 6). + +ith node: + CONCR (heap).node (i). + +END PROC dump lisp heap; + + +PROC lisp storage (INT VAR size, used): + size := max size; + used := CONCR (heap).size +END PROC lisp storage; + + +PROC collect lisp heap garbage: + mark all used nodes; + transfer all used high address nodes to unused low address nodes; + adjust all pointers to cleared high address area and unmark all nodes; + adjust size. + +mark all used nodes: + INT VAR i; + FOR i FROM 2 UPTO 28 REP + x mark (i) + PER. + +transfer all used high address nodes to unused low address nodes: + INT VAR high address :: CONCR (heap).size + 1, + low address :: 0; + REP + find next lower used high address node; + IF no used high address node found THEN + LEAVE transfer all used high address nodes to unused low address nodes + FI; + find next higher unused low address node; + IF no unused low address node found THEN + LEAVE transfer all used high address nodes to unused low address nodes + FI; + transfer high address node to low address node + PER. + +find next lower used high address node: + REP + high address DECR 1 + UNTIL high address node marked PER. + +high address node marked: + high address node.status < 0. + +no used high address node found: + low address = high address. + +find next higher unused low address node: + REP + low address INCR 1 + UNTIL low address node not marked OR low address = high address PER. + +low address node not marked: + low address node.status > 0. + +no unused low address node found : + low address = high address. + +transfer high address node to low address node: + low address node.status := high address node.status; + low address node.head := high address node.head; + low address node.tail := high address node.tail; + high address node.head := low address. + +adjust all pointers to cleared high address area and unmark all nodes: + (* 'high address' should now point to the last node of the used area *) + FOR low address FROM 1 UPTO high address REP + unmark low address node; + SELECT low address node.status OF + CASE oblist bone: adjust head + CASE atomic, + non atomic, + property indicator, + property root, + flag indicator: adjust head; adjust tail + CASE text data, character data: adjust tail + CASE int data: + OTHERWISE x lisp error ("Status " + text (low address node.status) + + " gefunden bei pointer Justage") + END SELECT + PER. + +unmark low address node: + low address node.status := - low address node.status. + +adjust head: + IF low address node.head > high address THEN + low address node.head := node (low address node.head).head + FI. + +adjust tail: + IF low address node.tail > high address THEN + low address node.tail := node (low address node.tail).head + FI. + +adjust size: + CONCR (heap).size := high address. + +low address node: + node (low address). + +high address node: + node (high address). + +node: + CONCR (heap).node. + +END PROC collect lisp heap garbage; + + +PROC x mark (INT CONST ptr): + IF node not yet marked THEN + mark node; + SELECT - ptr node.status OF + CASE oblist bone: x mark (ptr node.head) + CASE atomic, + non atomic, + property indicator, + property root, + flag indicator: x mark (ptr node.head); x mark (ptr node.tail) + CASE text data, character data: x mark (ptr node.tail) + CASE int data: + OTHERWISE error stop ("Status " + text (- ptr node.status) + + " gefunden beim Markieren") + END SELECT + FI. + + +node not yet marked: + ptr node.status > 0. + +mark node: + ptr node.status := - ptr node.status. + +ptr node: + CONCR (heap).node (ptr) + +END PROC x mark; + + +TYPE SYM = INT; + + +OP := (SYM VAR left, SYM CONST right): + CONCR (left) := CONCR (right) +END OP :=; + + +LET atomic = 1, + non atomic = 2, + oblist bone = 3, + property indicator = 4, + property root = 5, + flag indicator = 6, + text data = 7, + character data = 8, + int data = 9; + +SYM CONST nil :: SYM :(35), (* 'x initialize oblist and heap size' will *) + pname :: SYM :(44); (* place the atom NIL at node 35 and PNAME *) + (* at node 44 *) + + +(***************************** basic functions ****************************) + + +SYM PROC head (SYM CONST sym): + SELECT status of sym OF + CASE atomic: error stop ("Atome haben keinen head"); nil + CASE non atomic: SYM :(head of sym) + CASE oblist bone, + property indicator, + property root, + flag indicator : x lisp error ("Versteckter Knoten, Type:" + + text (status of sym)); + nil + CASE text data, + character data, + int data : error stop ("Daten haben keinen head"); nil + OTHERWISE x lisp error ("Illegaler Status " + text (status of sym)); + nil + END SELECT. + +status of sym: + sym node.status. + +head of sym: + sym node.head. + +sym node: + CONCR (heap).node (CONCR (sym)) + +END PROC head; + + +SYM PROC x head (SYM CONST sym): + SYM :(CONCR (heap).node (CONCR (sym)).head) +END PROC x head; + + +PROC set head (SYM CONST sym, new head): + SELECT status of sym OF + CASE atomic: errorstop ("Atome haben keinen head") + CASE non atomic: head of sym := CONCR (new head) + CASE oblist bone, + property indicator, + property root, + flag indicator : x lisp error ("Versteckter Knoten, Type:" + + text (status of sym)) + CASE text data, + character data, + int data : error stop ("Daten haben keinen head") + OTHERWISE x lisp error ("Illegaler Status " + text (status of sym)) + END SELECT. + +status of sym: + sym node.status. + +head of sym: + sym node.head. + +sym node: + CONCR (heap).node (CONCR (sym)). + +END PROC set head; + + +PROC x set head (SYM CONST sym, new head): + CONCR (heap).node (CONCR (sym)).head := CONCR (new head) +END PROC x set head; + + +SYM PROC tail (SYM CONST sym): + SELECT status of sym OF + CASE atomic: error stop ("Atome haben keinen tail"); nil + CASE non atomic: SYM :(tail of sym) + CASE oblist bone, + property indicator, + flag indicator : x lisp error ("Versteckter Knoten:" + + text (status of sym)); + nil + CASE text data, + character data, + int data : error stop ("Daten haben keinen tail"); nil + OTHERWISE x lisp error ("Illegaler Status: "+ text (status of sym)); + nil + END SELECT. + +status of sym: + sym node.status. + +tail of sym: + sym node.tail. + +sym node: + CONCR (heap).node (CONCR (sym)). + +END PROC tail; + + +SYM PROC x tail (SYM CONST sym): + SYM :(CONCR (heap).node (CONCR (sym)).tail) +END PROC x tail; + + +PROC set tail (SYM CONST sym, new tail): + SELECT status of sym OF + CASE atomic: error stop ("Atome haben keinen tail") + CASE non atomic: tail of sym := CONCR (new tail) + CASE oblist bone, + property indicator, + property root, + flag indicator : x lisp error ("Versteckter Knoten, Type: " + + text (status of sym)) + CASE text data, + character data, + int data : error stop ("Daten tails sind unveraenderbar") + OTHERWISE x lisp error ("Illegaler Status: " + text (status of sym)) + END SELECT. + +status of sym: + sym node.status. + +tail of sym: + sym node.tail. + +sym node: + CONCR (heap).node (CONCR (sym)). + +END PROC set tail; + + +PROC x set tail (SYM CONST sym, new tail): + CONCR (heap).node (CONCR (sym)).tail := CONCR (new tail) +END PROC x set tail; + + +SYM PROC cons (SYM CONST head, tail): + SYM VAR result; + search free node; + result node.status := non atomic; + result node.head := CONCR (head); + result node.tail := CONCR (tail); + result. + +search free node: + IF CONCR (heap).size = max size THEN + error stop ("LISP Heap Ueberlauf"); + LEAVE cons WITH nil + ELSE + CONCR (heap).size INCR 1; + CONCR (result) := CONCR (heap).size; cout(CONCR(result)) + FI. + +result node: + CONCR (heap).node (CONCR (result)). + +END PROC cons; + + +BOOL PROC eq (SYM CONST sym 1, sym 2): + CONCR (sym 1) = CONCR (sym 2) +END PROC eq; + + +BOOL PROC equal (SYM CONST sym 1, sym 2): + eq (sym 1, sym 2) COR have same value. + +have same value: + IF sym 1 node.status <> sym 2 node.status THEN + FALSE + ELSE + SELECT sym 1 node.status OF + CASE atomic: FALSE + CASE non atomic: equal (head (sym 1), head (sym 2)) CAND + equal (tail (sym 1), tail (sym 2)) + CASE oblist bone, + property indicator, + property root, + flag indicator: x lisp error ("Versteckter Knoten, Type: " + + text (x status (sym 1))); FALSE + CASE text data: equal texts + CASE character data: sym 1 node.head = sym 2 node.head + CASE int data: sym 1 node.head = sym 2 node.head AND + sym 1 node.tail = sym 2 node.tail + OTHERWISE x lisp error ("Ilegaler Status " + text (x status (sym 1))); + FALSE + END SELECT + FI. + +equal texts: + equal length CAND equal character sequence. + +equal length: + eq (x head (sym 1), x head (sym 2)). + +equal character sequence: + SYM VAR actual sym 1 character :: sym 1, + actual sym 2 character :: sym 2; + INT VAR i; + FOR i FROM 1 UPTO sym 1 node. head REP + actual sym 1 character := x tail (actual sym 1 character); + actual sym 2 character := x tail (actual sym 2 character); + IF eq (actual sym 1 character, actual sym 2 character) THEN + LEAVE equal character sequence WITH TRUE + FI; + IF x status (actual sym 1 character) <> character data OR + x status (actual sym 2 character) <> character data THEN + x lisp error ("Ungueltiges Zeichen im text"); + LEAVE equal character sequence WITH FALSE + FI; + IF CONCR (x head (actual sym 1 character)) <> + CONCR (x head (actual sym 2 character)) THEN + LEAVE equal character sequence WITH FALSE + FI + PER; + TRUE. + +sym 1 node: + CONCR (heap).node (CONCR (sym 1)). + +sym 2 node: + CONCR (heap).node (CONCR (sym 2)). + +END PROC equal; + + +BOOL PROC null (SYM CONST sym): + CONCR (sym) = CONCR (nil) +END PROC null; + + +BOOL PROC atom (SYM CONST sym): + SELECT x status (sym) OF + CASE atomic, + text data, + character data, + int data: TRUE + CASE non atomic: FALSE + CASE oblist bone, + property indicator, + property root, + flag indicator : x lisp error ("Versteckter Knoten, Type:" + + text (x status (sym))); TRUE + OTHERWISE x lisp error ("Illegaler Status " + + text (x status (sym))); TRUE + END SELECT +END PROC atom; + + +BOOL PROC is named atom (SYM CONST sym): + x status (sym) = atomic +END PROC is named atom; + + +(*------------------- internal heap management routines ------------------*) + + +SYM PROC x new node (INT CONST status, head, tail): + IF CONCR (heap).size = max size THEN + error stop ("LISP Heap Ueberlauf"); nil + ELSE + CONCR (heap).size INCR 1; + new node.status := status; + new node.head := head; + new node.tail := tail; + SYM :(CONCR (heap).size) + FI. + +new node: + node (CONCR (heap).size). + +node: + CONCR (heap).node. + +END PROC x new node; + + +INT PROC x status (SYM CONST sym): + CONCR (heap).node (CONCR (sym)).status +END PROC x status; + + +(**************************** oblist management ***************************) + + +(* Oblist organization: + +(NOTE: + + +-----------------+ + l <status> l + All nodes are represented as +--------+--------+ in all comments + l <head> l <tail> l of this packet. + +--------+--------+ + +END OF NOTE) + + +The 'oblist' (object list) is organized as follows: + + +-------------+ + l oblist bone l + +------+------+ +--> list of all atoms whose print names begin with "§" + l o l XXXX l l + +---+--+------+ l + +------------+ + +-------------+ + l oblist bone l + +------+------+ +--> list of all atoms whose print names begin with "A" + l o l XXXX l l + +---+--+------+ l + +------------+ + . + . + . + + +-------------+ + l oblist bone l + +------+------+ +--> list of all atoms whose print names begin with "Z" + l o l XXXX l l + +---+--+------+ l + +------------+ + + +These nodes with status 'oblist bone' form the oblist skeleton. As long as +the lisp heap exists, they are stored contiguously in nodes 2 - 28; they +cannot be changed directly by the user. This way of storing the oblist +skeleton allows a hashing scheme to be applied when searching for an atom +with a given name. The hash width of 27 is the smallest one thas distributes +all atoms according to their character; with a smaller hash size, two or +more lists would be merged, with the effect that some of the atom lists +would contain atoms beginning with different characters. + + +The list of all atoms whose print names begin with a certain character +is organized as follows: + + +-------------+ + l atomic l + +------+------+ + l o l o---+--> property list of first atom + +---+--+------+ + l + V + +-------------+ + l atomic l + +------+------+ + l o l o---+--> property list of 2nd atom + +---+--+------+ + l + V + . + . + . + + l + V + +-------------+ + l atomic l + +------+------+ + l o l o---+--> property list of last atom + +---+--+------+ + l + V + oblist bone where the atom list began + + +These lists cannot be acessed directly by the user, too. +*) + + + +PROC x initialize oblist and heap size: + node (1).status := text data; + node (1).head := 32 (* blank *); + node (1).tail := 1; + INT VAR i; + FOR i FROM 2 UPTO 28 REP + node (i).status := oblist bone; + node (i).head := i + PER; + CONCR (heap).size := 28. + +node: + CONCR (heap).node. + +END PROC x initialize oblist and heap size; + + +(*++++++++++++++++++++++++++++++ oblist dump +++++++++++++++++++++++++++++*) + + +SYM VAR actual oblist bone :: SYM :(0), + actual atom :: SYM :(0); + + +PROC begin oblist dump: + actual oblist bone := SYM :(2); + actual atom := SYM :(2) +END PROC begin oblist dump; + + +SYM PROC next atom: + actual atom := x head (actual atom); + WHILE no more atoms in this atom list REP + try next oblist bone + PER; + actual atom. + +no more atoms in this atom list: + (* NIL is given as last atom when 'next atom' is called repeatedly, so *) + (* it can serve as a terminator. So NIL "does not count" if it is *) + (* encountered during one of the calls. *) + IF null (actual atom) THEN + actual atom := x head (actual atom) + FI; + eq (actual atom, actual oblist bone). + +try next oblist bone: + IF actual oblist bone is last oblist bone THEN + actual atom := SYM :(2); + LEAVE next atom WITH nil + FI; + CONCR (actual oblist bone) INCR 1; + actual atom := x head (actual oblist bone). + +actual oblist bone is last oblist bone: + CONCR (actual oblist bone) = 28. + +END PROC next atom; + + +(*+++++++++++++++++++++++ atom search and creation +++++++++++++++++++++++*) + + +SYM VAR predecessor, result; + (* Variables used for communication between the internal search *) + (* procedures and the procedures calling them. *) + + +SYM PROC atom (TEXT CONST name): + x search atom (name); + IF atom not already existing THEN + nil + ELSE + result + FI. + +atom not already existing: + x status (result) = oblist bone. + +END PROC atom; + + +SYM PROC new atom (TEXT CONST name): + x search atom (name); + IF atom not already existing THEN + x create new atom (name); + FI; + result. + +atom not already existing: + x status (result) = oblist bone. + +END PROC new atom; + + +PROC create atom (TEXT CONST name): + x search atom (name); + IF atom already existing THEN + error stop ("Atom " + name + " existiert bereits") + ELSE + x create new atom (name) + FI. + +atom already existing: + x status (result) <> oblist bone. + +END PROC create atom; + + +PROC delete atom (SYM CONST atom): + IF is named atom (atom) THEN + IF null (atom) OR eq (atom, pname) THEN + error stop ("Dies Atom darf nicht geloescht werden") + ELSE + search predecessor; + delete atom from atom list + FI + ELSE + error stop ("Nur benannte Atome können geloescht werden") + FI. + +search predecessor: + predecessor := x head (atom); + WHILE NOT eq (x head (predecessor), atom) REP + predecessor := x head (predecessor) + PER. + +delete atom from atom list: + x set head (predecessor, x head (atom)). + +END PROC delete atom; + + +PROC x search atom (TEXT CONST name): + CONCR (result) := (code (name SUB 1) + 17) MOD 27 + 2; + (* This formula places the list of atoms beginning with "§" at the *) + (* first oblist bone, the list of atoms beginning with "A" at the *) + (* at the second one, and so on. (See also the big comment in lines *) + (* 600 - 700) *) + REP + predecessor := result; + result := x head (predecessor); + UNTIL end of atom list reached COR right atom found PER. + +end of atom list reached: + x status (result) = oblist bone. + +right atom found: + SYM VAR actual character node := property (result, pname); + IF NOT is text (actual character node) THEN + x lisp error ("Namen erwartet"); + LEAVE right atom found WITH FALSE + FI; + IF CONCR (x head (actual character node)) <> length (name) THEN + FALSE + ELSE + INT VAR i; + FOR i FROM 1 UPTO length (name) REP + to next character node; + check wether is character data node; + check wether character matches; + PER; + TRUE + FI. + +to next character node: + actual character node := x tail (actual character node). + +check wether is character data node: + IF x status (actual character node) <> character data THEN + x lisp error ("Zeichenkette erwartet"); + LEAVE right atom found WITH FALSE + FI. + +check wether character matches: + IF code (name SUB i) <> CONCR (x head (actual character node)) THEN + LEAVE right atom found WITH FALSE + FI. + +END PROC x search atom; + + +PROC x create new atom (TEXT CONST name): + (* It is necessary that 'x search atom' has been executed before *) + (* calling 'x create new atom' because this procedure relies on the *) + (* value of 'predecessor'. *) + enable stop; + SYM CONST sym name :: sym (name); + IF CONCR (heap).size + 3 > max size THEN + error stop ("LISP Heap Ueberlauf") + FI; + result := newly created atom; + x set head (predecessor, result). + +newly created atom: + x new node (atomic, CONCR (oblist bone node), CONCR (property list)). + +oblist bone node: + x head (predecessor). + +property list: + x new node (property indicator, CONCR (pname), property root node). + +property root node: + CONCR (x new node (property root, CONCR (sym name), CONCR (nil))). + +END PROC x create new atom; + + +(************************* property list handling *************************) + +(* +The property lists consist of chained units of the structure + + +--------------------+ +---------------+ + l property indicator l l property root l + +----------+---------+ +-------+-------+ + l o l o----+-->l o l o---+--> . . . + +----+-----+---------+ +---+---+-------+ + l l + V V + property id property + + +or + + +----------------+ + l flag indicator l + +--------+-------+ + l o l o---+--> . . . + +---+----+-------+ + l + V + flag id + + + +The property lists cannot be altered or read directly, too. + +For property list handling there exist procedures that insert, change, read +and delete properties resp. flags. Thus, the only thing that can be done +with any property of an atom without using these special procedures, is +comparing to or 'cons'ing with some other S-expression. +At any given time the property list of any atom (including 'NIL') contains +the property 'PNAME' giving the print name of the atom, stored as a list of +characters. This special property cannot be altered, overwritten by 'add +property' or deleted. +*) + + +(*++++++++++++++++++++++++++ property list dump ++++++++++++++++++++++++++*) + + +SYM VAR actual property list node :: nil; + + +PROC begin property list dump (SYM CONST atom): + actual property list node := x tail (atom) +END PROC begin property list dump; + + +PROC next property (SYM VAR property id, property): + IF null (actual property list node) THEN + property id := nil; + property := nil + ELSE + SELECT x status (actual property list node) OF + CASE flag indicator: get flag id + CASE property indicator: get property id and property + OTHERWISE x lisp error ("Flagge oder Eigenschaft erwartet und nicht: " + + text (x status (actual property list node))) + END SELECT + FI. + +get flag id: + property id := x head (actual property list node); + actual property list node := x tail (actual property list node); + property := nil. + +get property id and property: + property id := x head (actual property list node); + actual property list node := x tail (actual property list node); + IF x status (actual property list node) = property root THEN + property := x head (actual property list node); + actual property list node := x tail (actual property list node) + ELSE + x lisp error ("Eigenschaftswurzel erwartet, nicht:" + + text (x status (actual property list node))); + property := nil + FI. + +END PROC next property; + + +(*+++++++++++++++++++++++++++++ properties +++++++++++++++++++++++++++++++*) + + +SYM VAR last atom :: SYM :(0), + p list predecessor, + p list result; + + +PROC add property (SYM CONST atom, property id, property): + IF eq (property id, pname) THEN + errorstop ("Der PNAME eines Atoms darf nicht versteckt sein") + ELSE + IF CONCR (heap).size + 2 > max size THEN + error stop ("LISP Heap Ueberlauf"); + LEAVE add property + FI; + x set tail (atom, new property plus old property list); + IF eq (atom, last atom) AND + eq (property id, x head (p list result)) THEN + p list predecessor := atom; + p list result := x tail (atom) + FI + FI. + +new property plus old property list: + x new node (property indicator, + CONCR (property id), CONCR (property root plus old property list)). + +property root plus old property list: + x new node (property root, CONCR (property), CONCR (old property list)). + +old property list: + x tail (atom) + +END PROC add property; + + +PROC alter property (SYM CONST atom, property id, new property): + IF eq (property id, pname) THEN + error stop ("Namen kann man nicht aendern") + ELSE + x search property id (atom, property id); + IF null (p list result) THEN + error stop ("Eigenschaft existiert nicht") + ELSE + x set head (x tail (p list result), new property) + FI + FI +END PROC alter property; + + +SYM PROC property (SYM CONST atom, property id): + x search property id (atom, property id); + IF null (p list result) THEN + nil + ELSE + x head (x tail (p list result)) + FI +END PROC property; + + +PROC delete property (SYM CONST atom, property id): + IF eq (property id, pname) THEN + errorstop ("Der Name eines Atoms darf nicht geloescht werden") + ELSE + x search property id (atom, property id); + IF NOT null (p list result) THEN + x set tail (p list predecessor, x tail (x tail (p list result))); + last atom := SYM :(0) + FI + FI +END PROC delete property; + + +BOOL PROC property exists (SYM CONST atom, property id): + x search property id (atom, property id); + NOT null (p list result) +END PROC property exists; + + +PROC x search property id (SYM CONST atom, property id): + IF eq (last atom, atom) AND eq (x head (p list result), property id) THEN + LEAVE x search property id + FI; + last atom := atom; + p list predecessor := atom; + REP + p list result := x tail (p list predecessor); + IF end of property list THEN + last atom := SYM :(0); + LEAVE x search property id + FI; + SELECT x status (p list result) OF + CASE flag indicator: p list predecessor := p list result + CASE property indicator: check wether property root node follows; + IF correct property id found THEN + LEAVE x search property id + ELSE + p list predecessor := xtail (p list result) + FI + CASE property root: xlisperror("Unordentliche Eigenschaftwurzel"); + p list result := nil; + last atom := SYM :(0); + LEAVE x search property id + OTHERWISE x lisp error ("Eigenschaften erwartet und nicht: " + + text (x status (p list result))); + p list result := nil; + last atom := SYM :(0); + LEAVE x search property id + END SELECT + PER. + +end of property list: + null (p list result). + +check wether property root node follows: + IF x status (x tail (p list result)) <> property root THEN + x lisp error ("Eigenschaftswurzel erwartet"); + p list result := nil; + last atom := SYM :(0); + LEAVE x search property id + FI. + +correct property id found: + eq (x head (p list result), property id). + +END PROC x search property id; + + +(*++++++++++++++++++++++++++++++++ flags +++++++++++++++++++++++++++++++++*) + + +PROC add flag (SYM CONST atom, flag id): + enable stop; + x set tail (atom, new flag plus old property list). + +new flag plus old property list: + x new node (flag indicator, CONCR (flag id), old property list). + +old property list: + CONCR (x tail (atom)) + +END PROC add flag; + + +BOOL PROC flag (SYM CONST atom, flag id): + x search flag id (atom, flag id); + NOT null (result) +END PROC flag; + + +PROC delete flag (SYM CONST atom, flag id): + x search flag id (atom, flag id); + IF NOT (is error COR null (result)) THEN + x set tail (predecessor, x tail (result)) + FI +END PROC delete flag; + + +PROC x search flag id (SYM CONST atom, flag id): + predecessor := atom; + REP + result := x tail (predecessor); + IF end of property list THEN + LEAVE x search flag id + FI; + SELECT x status (result) OF + CASE property root, property indicator: predecessor := result + CASE flag indicator: IF correct flag id found THEN + LEAVE x search flag id + ELSE + predecessor := result + FI + OTHERWISE x lisp error ("Eigenschaften erwartet und nicht:" + + text (x status (result))); + result := nil; + LEAVE x search flag id + END SELECT + PER. + +end of property list: + null (result). + +correct flag id found: + eq (x head (result), flag id). + +END PROC x search flag id; + + +(****** Conversion of non-LISP data to LISP structures and vice versa *****) + + +TEXT PROC text (SYM CONST sym): + IF is text (sym) THEN + TEXT VAR result := ""; + SYM VAR actual node :: sym; + INT VAR i; + FOR i FROM 1 UPTO CONCR (x head (sym)) REP + actual node := x tail (actual node); + result CAT actual character + PER; + result + ELSE + error stop ("ist kein text"); + "" + FI. + +actual character: + IF x status (actual node) <> character data THEN + x lisp error ("Zeichenfolge erwartet"); + LEAVE text WITH result + FI; + code (CONCR (x head (actual node))). + +END PROC text; + + +BOOL PROC is text (SYM CONST sym): + x status (sym) = text data +END PROC is text; + + +SYM PROC sym (TEXT CONST text): + SYM VAR result :: x new node (text data, + length (text), CONCR (nil)), + actual character node :: result; + INT VAR length of text; + ignore blanks at end of text; + INT VAR i; + FOR i FROM 1 UPTO length of text REP + x set tail (actual character node, new next character node); + actual character node := x tail (actual character node) + PER; + result. + +ignore blanks at end of text: + FOR length of text FROM length (text) DOWNTO 0 REP + IF (text SUB length of text) <> " " THEN + LEAVE ignore blanks at end of text + FI + PER; + length of text := 0. + +new next character node: + x new node (character data, code (text SUB i), 1). + +END PROC sym; + + +INT PROC character (SYM CONST sym): + IF x status (sym) = character data THEN + CONCR (x head (sym)) + ELSE + error stop ("ist kein Charakter"); + -1 + FI +END PROC character; + + +BOOL PROC is character (SYM CONST sym): + x status (sym) = character data +END PROC is character; + + +SYM PROC sym character (INT CONST char): + x new node (character data, char MOD 256, 1) +END PROC sym character; + + +INT PROC int 1 (SYM CONST sym): + IF x status (sym) = int data THEN + CONCR (x head (sym)) + ELSE + error stop ("ist keine Zahl"); + -1 + FI +END PROC int 1; + + +INT PROC int 2 (SYM CONST sym): + IF x status (sym) = int data THEN + CONCR (x tail (sym)) + ELSE + error stop ("ist keine Zahl"); + -1 + FI +END PROC int 2; + + +BOOL PROC is int pair (SYM CONST sym): + x status (sym) = int data +END PROC is int pair; + + +SYM PROC sym (INT CONST int 1, int 2): + x new node (int data, int 1, int 2) +END PROC sym; + + +(********************* internal error routine *****************************) + + +PROC x lisp error (TEXT CONST error message): + error stop (""13"LISP SYSTEM FEHLER: " + error message ) +END PROC x lisp error; + + +END PACKET lisp heap and oblist management; + + + +PACKET name (* Autor: J.Durchholz *) + (* Datum: 15.06.1982 *) + DEFINES (* Version 1.1.1 *) + + name: + +TEXT PROC name (SYM CONST sym): + IF is named atom (sym) THEN + text (property (sym, pname)) + ELSE + ""15"IST_KEIN_ATOM"14"" + FI +END PROC name; + + +END PACKET name; + + + +PACKET lisp storage info (* Autor: J.Durchholz *) + (* Datum: 23.08.1982 *) + DEFINES (* Version 1.1.1 *) + + lisp storage info: + + +PROC lisp storage info: + INT VAR size, used; + lisp storage (size, used); + out (""13""10" "); + put (used); + put ("Knoten von"); + put (size); + put line ("Knoten des LISP-Heaps sind belegt!") +END PROC lisp storage info; + + +END PACKET lisp storage info; + diff --git a/lang/lisp/1.8.7/src/lisp.2 b/lang/lisp/1.8.7/src/lisp.2 new file mode 100644 index 0000000..28e6924 --- /dev/null +++ b/lang/lisp/1.8.7/src/lisp.2 @@ -0,0 +1,584 @@ +PACKET character buffer (* Autor : J.Durchholz *) + (* Datum : 09.05.1984 *) + DEFINES (* Version 1.7.2 *) + (* 21.2.83. hey 293, 450,97,361 *) + get char, + line nr, + init char buffer: + + +TEXT VAR buffer; +INT VAR pointer, + line; + + +INT PROC line nr: + line +END PROC line nr; + + +PROC init char buffer: + buffer := ""; + pointer := 1; + line := 0; +END PROC init char buffer; + + +PROC get char (FILE VAR f, TEXT VAR char): + IF buffer empty THEN + try to find nonempty line and put it into buffer; + char := " "; + pointer := 1 + ELSE + char := buffer SUB pointer; + pointer INCR 1 + FI. + +buffer empty: + pointer > length (buffer). + +try to find nonempty line and put it into buffer: + REP + IF eof (f) THEN + char := ""; + LEAVE get char + FI; + get line (f, buffer); + line INCR 1 + UNTIL buffer <> "" PER. + +END PROC get char; + + +END PACKET character buffer; + + + + +PACKET lisp io (* Autor: J.Durchholz *) + (* Datum: 10.09.1982 *) + DEFINES (* Version 4.1.3 *) + (* Änderung: notebook *) + put, note, (* 13.3.86 I. Ley *) + verbose lisp output, + get, + get all: + + +BOOL VAR verbose :: FALSE; + + +PROC verbose lisp output (BOOL CONST b): + verbose := b +END PROC verbose lisp output; + +BOOL PROC verbose lisp output: + verbose +END PROC verbose lisp output; + + +PROC put (SYM CONST sym): + IF atom (sym) THEN + put atom + ELSE + put structure + FI. + +put atom: + IF is named atom (sym) THEN + put (name (sym)) + ELIF is int pair (sym) THEN + put (int 1 (sym)) + ELIF is text (sym) THEN + IF verbose THEN + TEXT VAR buffer :: text (sym); + change all (buffer, """", """"""); + buffer CAT """"; + put ("""" + buffer) + ELSE + write (text (sym)) + FI + ELIF is character (sym) THEN + IF verbose THEN + buffer := "'"; + buffer CAT code (character (sym)); + buffer CAT "'"; + put (buffer) + ELSE + out (code (character (sym))) + FI + ELSE + put (""15"UNBEKANNTER_ATOM_TYP"14"") + FI. + +put structure: + put ("("); + SYM VAR actual node := sym; + REP + put (head (actual node)); + actual node := tail (actual node) + UNTIL atom (actual node) PER; + IF NOT null (actual node) THEN + put ("."); + put (actual node) + FI; + put (")"). + +END PROC put; + +PROC put (FILE VAR f, SYM CONST sym): + IF atom (sym) THEN + put atom + ELSE + put structure + FI. + +put atom: + IF is named atom (sym) THEN + put (f, name (sym)) + ELIF is int pair (sym) THEN + put (f, int 1 (sym)) + ELIF is text (sym) THEN + IF verbose THEN + TEXT VAR buffer :: text (sym); + change all (buffer, """", """"""); + buffer CAT """"; + put (f, """" + buffer) + ELSE + put (f, text (sym)) + FI + ELIF is character (sym) THEN + IF verbose THEN + buffer := "'"; + buffer CAT code (character (sym)); + buffer CAT "'"; + put (f, buffer) + ELSE + put (f, code (character (sym))) + FI + ELSE + put ( f, ""15"UNBEKANNTER_ATOM_TYP"14"") + FI. + +put structure: + put (f, "("); + SYM VAR actual node := sym; + REP + put (f, head (actual node)); + actual node := tail (actual node) + UNTIL atom (actual node) PER; + IF NOT null (actual node) THEN + put (f, "."); + put (f, actual node) + FI; + put (f, ")"). + +END PROC put; + + PROC note (SYM CONST sym): + IF atom (sym) THEN + note atom + ELSE + note structure + FI. + +note atom: + IF is named atom (sym) THEN + note ( name (sym)) + ELIF is int pair (sym) THEN + note (int 1 (sym)) + ELIF is text (sym) THEN + IF verbose THEN + TEXT VAR buffer :: text (sym); + change all (buffer, """", """"""); + buffer CAT """"; + note ( """" + buffer) + ELSE + note ( text (sym)) + FI + ELIF is character (sym) THEN + IF verbose THEN + buffer := "'"; + buffer CAT code (character (sym)); + buffer CAT "'"; + note ( buffer) + ELSE + note ( code (character (sym))) + FI + ELSE + note ( ""15"UNBEKANNTER_ATOM_TYP"14"") + FI. + +note structure: + note ( "("); + SYM VAR actual node := sym; + REP + note ( head (actual node)); + actual node := tail (actual node) + UNTIL atom (actual node) PER; + IF NOT null (actual node) THEN + note ( "."); + note ( actual node) + FI; + note ( ")"). + +END PROC note; + +PROC get (FILE VAR f, SYM VAR s): + initialize scanner (f); + IF NOT get s expression (s) THEN + error ("LISP-Ausdruck erwartet") + FI; + scanner postprocessing (f) +END PROC get; + + +(**************************** parser for 'get' ****************************) + + +LET end of file type = 0, + name type = 1, + text type = 2, + character type = 3, + int type = 4, + other char type = 5; + + +BOOL PROC get s expression (SYM VAR s): + (* The boolean result indicates wether the error has not occurred that *) + (* 'get next symbol' was called, but then the symbol was not expected *) + (* and thus could not be processed. *) + get next symbol; + SELECT symbol type OF + CASE end of file type: FALSE + CASE name type: s := new atom (symbol); TRUE + CASE text type: s := sym (symbol); TRUE + CASE character type: s := sym character (code (symbol)); TRUE + CASE int type: s := sym (int (symbol), -1); TRUE + CASE other char type: get structure + OTHERWISE error ("EINLESEFEHLER: unbekannter Symboltyp: " + + text (symbol type)); TRUE + END SELECT. + +get structure: + IF symbol <> "(" THEN + FALSE + ELSE + get list; + IF symbol type <> other char type OR symbol <> ")" THEN + error (">> ) << erwartet"); + FALSE + ELSE + TRUE + FI + FI. + +get list: + SYM VAR father, son; + IF get s expression (son) THEN + get list elements; + ELSE + s := nil + FI. + +get list elements: + father := cons (son, nil); + s := father; + WHILE get s expression (son) REP + set tail (father, cons (son, nil)); + father := tail (father) + PER; + IF symbol type = other char type AND symbol = "." THEN + IF get s expression (son) THEN + set tail (father, son); + get next symbol + ELSE + error ("LISP-Ausdruck nach dem Punkt erwartet") + FI + FI. + +END PROC get s expression; + + +(********************* scanner for 'get x espression' *********************) + + +FILE VAR infile; + + +PROC initialize scanner (FILE CONST f): + infile := f; + no input errors := TRUE; + init char buffer; + get char (infile, actual char) +END PROC initialize scanner; + + +PROC scanner postprocessing (FILE VAR f): + f := infile +END PROC scanner postprocessing; + + +TEXT VAR symbol; INT VAR symbol type; + + +PROC get next symbol: + skip blanks; + IF actual char = "" THEN + symbol := "DATEIENDE"; + symbol type := end of file type + ELIF is letter THEN + get name + ELIF is digit or sign THEN + get integer + ELIF is double quote THEN + get text + ELIF is single quote THEN + get character + ELSE + get other char + FI . + +is letter: + IF "a" <= actual char AND actual char <= "z" THEN + actual char := code (code (actual char) - code ("a") + code ("A")); + TRUE + ELSE + "§" <= actual char AND actual char <= "Z" + FI. + +get name: + symbol type := name type; + symbol := actual char; + REP + get char (infile, actual char); + IF is neither letter nor digit THEN + LEAVE get name + FI; + symbol CAT actual char + PER. + +is neither letter nor digit: + NOT (is letter OR is digit OR is underscore). + +is digit: + "0" <= actual char AND actual char <= "9". + +is underscore: + actual char = "_". + +is digit or sign: + is digit OR actual char = "+" OR actual char = "-". + +get integer: + symbol type := int type; + IF actual char = "+" THEN + get char (infile, actual char); + skip blanks; + symbol := actual char + ELIF actual char = "-" THEN + symbol := "-"; + get char (infile, actual char); + skip blanks; + symbol CAT actual char + ELSE + symbol := actual char + FI; + REP + get char (infile, actual char); + IF NOT is digit THEN + LEAVE get integer + FI; + symbol CAT actual char + PER. + +is double quote: + actual char = """". + +get text: + symbol := ""; + symbol type := text type; + REP + get char (infile, actual char); + IF is double quote THEN + get char (infile, actual char); + IF NOT is double quote THEN LEAVE get text + FI + ELIF actual char = "" THEN LEAVE get text (*hey*) + FI; + symbol CAT actual char + PER. + +is single quote: + actual char = "'". + +get character: + symbol type := character type; + get char (infile, symbol); + get char (infile, actual char); + IF actual char <> "'" THEN + error (">> ' << erwartet") + ELSE + get char (infile, actual char) + FI. + +get other char: + symbol type := other char type; + symbol := actual char; + get char (infile, actual char). + +END PROC get next symbol; + + +TEXT VAR actual char; + + +PROC skip blanks: + INT VAR comment depth :: 0; + WHILE is comment OR actual char = " " REP + get char (infile, actual char) + PER. + +is comment: + IF actual char = "{" THEN + comment depth INCR 1; + TRUE + ELIF actual char = "}" THEN + IF comment depth = 0 THEN + error (">> { << fehlt") + ELSE + comment depth DECR 1 + FI; + TRUE + ELSE + IF comment depth > 0 THEN + IF actual char = "" THEN + error ("DATEIENDE im Kommentar"); + FALSE + ELSE + TRUE + FI + ELSE + FALSE + FI + FI. + +END PROC skip blanks; + + +BOOL VAR no input errors; +FILE VAR errors; + + +PROC error (TEXT CONST error message): + out ("FEHLER in Zeile "); + out (text (line nr)); + out (" bei >> "); + out (symbol); + out (" << : "); + out (error message); + line; + IF no input errors THEN + no input errors := FALSE; + errors := notefile; modify(errors); + headline (errors, "Einlesefehler"); output(errors) + FI; + write (errors, "FEHLER in Zeile "); + write (errors, text (line nr)); + write (errors, " bei >> "); + write (errors, symbol); + write (errors, " << : "); + write (errors, error message); + line (errors) +END PROC error; + + +PROC get (SYM VAR sym): (*hey*) + disable stop; + FILE VAR in :: sequential file (modify, "LISP INPUT"), + out :: notefile; modify (out); + headline (out,"LISP OUTPUT"); + headline (in, "LISP INPUT"); + noteedit (in); + input (in); + get (in, sym); + WHILE NOT no input errors AND NOT is error REP + modify (errors); + headline (errors, " LISP-Fehlermeldungen"); + headline (in, " Bitte KORREKTEN LISP-Ausdruck"); + noteedit (in); + headline (errors, "notebook"); + input (in); + get (in, sym) + PER; +END PROC get; + + +PROC get all (FILE VAR f, SYM VAR sym): + get (f, sym); + skip blanks; + IF NOT eof (infile) THEN + error ("Hinter dem letzten Symbol des LISP-Ausdruck stehen noch Zeichen") + FI +END PROC get all; + + +END PACKET lisp io; + + + +PACKET lisp integer (* Autor: J.Durchholz *) + (* Datum: 30.08.1982 *) + DEFINES (* Version 1.1.2 *) + + sum, + difference, + product, + quotient, + remainder: + +SYM PROC sum (SYM CONST summand list): + INT VAR result := 0; + SYM VAR list rest := summand list; + WHILE NOT atom (list rest) REP + result INCR int 1 (head (list rest)); + list rest := tail (list rest) + PER; + IF NOT null (list rest) THEN + error stop ("Summandenliste endet falsch") + FI ; + sym (result, -1) +END PROC sum; + + +SYM PROC difference (SYM CONST minuend, subtrahend): + sym (int 1 (minuend) - int 1 (subtrahend), -1) +END PROC difference; + + +SYM PROC product (SYM CONST factor list): + INT VAR result := 1; + SYM VAR list rest := factor list; + WHILE NOT atom (list rest) REP + result := result * int 1 (head (list rest)); + list rest := tail (list rest) + PER; + IF NOT null (list rest) THEN + error stop ("Faktorenliste endet falsch") + FI; + sym (result, -1) +END PROC product; + + +SYM PROC quotient (SYM CONST dividend, divisor): + sym (int 1 (dividend) DIV int 1 (divisor), -1) +END PROC quotient; + + +SYM PROC remainder(SYM CONST dividend, divisor): + sym (int 1 (dividend) MOD int 1 (divisor), -1) +END PROC remainder; + + +END PACKET lisp integer; + diff --git a/lang/lisp/1.8.7/src/lisp.3 b/lang/lisp/1.8.7/src/lisp.3 new file mode 100644 index 0000000..a93463c --- /dev/null +++ b/lang/lisp/1.8.7/src/lisp.3 @@ -0,0 +1,767 @@ +PACKET lisp heap maintenance (* Autor: J.Durchholz *) + (* Datum: 09.05.1984 *) + DEFINES (* Version 1.7.2 *) + (* Testhilfe *) + create lisp system, (* hey, 02.3.83 : 121,334,542,732 *) + dump oblist: + + +PROC create lisp system (FILE VAR f, DATASPACE CONST new heap): + initialize lisp system (new heap); + input (f); + WHILE NOT eof (f) REP + TEXT VAR name; + get (f, name); + SYM CONST s :: new atom (name); + get (f, name); + SYM CONST property name :: new atom (name); + IF NOT null (property name) THEN + SYM VAR property; + get (f, property); + add property (s, property name, property) + FI + PER +END PROC create lisp system; + + +PROC dump oblist (FILE VAR f): + begin oblist dump; + REP + SYM CONST actual atom :: next atom; + put line (f, name (actual atom)); + dump property list + UNTIL null (actual atom) PER. + +dump property list: + begin property list dump (actual atom); + REP + SYM VAR id, value; + next property (id, value); + write (f, " "); + write (f, name (id)); + write (f, " "); + write (f, name (value)); + line (f) + UNTIL null (id) AND null (value) PER. + +END PROC dump oblist; + + +PROC dump oblist: + begin oblist dump; + REP + SYM CONST actual atom :: next atom; + put line (name (actual atom)); + dump property list + UNTIL null (actual atom) PER. + +dump property list: + begin property list dump (actual atom); + REP + SYM VAR id, value; + next property (id, value); + out (" "); + out (name (id)); + out (" "); + put line (name (value)); + UNTIL null (id) AND null (value) PER. + +END PROC dump oblist; + + +END PACKET lisp heap maintenance; + + + +PACKET lisp interpreter (* Autor: J.Durchholz *) + (* Datum: 27.12.1982 *) + DEFINES (* Version 3.1.7 *) + evalquote, + apply, + eval, + try: + + +(* SYM-objects used by the interpreter. They all point to constant structure + within the heap. As their address may change during garbage collection, + it must be possible to correct the references to them made by the + SYM-objects. That is the reason why they are declared VAR instead of CONST*) +SYM VAR lambda constant, + label constant, + quote constant, + function constant, + indefinite constant, + apval constant, + true constant, + false constant; + +SYM VAR errors; +BOOL VAR trace :: FALSE; + +PROC initialize constants: + lambda constant := new atom ("LAMBDA"); + label constant := new atom ("LABEL"); + quote constant := new atom ("QUOTE"); + function constant := new atom ("FUNCTION"); + indefinite constant := new atom ("INDEFINITE"); + apval constant := new atom ("APVAL"); + true constant := new atom ("T"); + false constant := new atom ("F"); + errors := new atom ("ERRORS") +END PROC initialize constants; + + +SYM PROC evalquote (SYM CONST expr): (*hey*) + enable stop; + initialize constants; + x apply ( head (expr), quote (tail (expr)), nil ) +END PROC evalquote; + + +SYM PROC quote (SYM CONST x): + IF eq (x,nil) THEN nil + ELSE set head (x, new head); set tail (x, quote (tail(x))); x + FI . +new head: + cons (quote constant, cons (head(x), nil) ) +END PROC quote; + + +SYM PROC apply (SYM CONST function, argument list, alist): + enable stop; + initialize constants; + x apply (function, argument list, alist) +END PROC apply; + + +SYM PROC x apply (SYM CONST function, argument list, alist): + IF trace THEN line; + put ("a p p l y :"); put (function); line; + put ("arguments :"); put (argument list); line; + FI; + SYM VAR new alist; + initialize for alist insertion; + reduce actual fn to lambda expression; + insert parameter evaluated argument pairs in reversed order in new alist; + function body evaluation. + +reduce actual fn to lambda expression: + SYM VAR actual fn :: function; + REP + IF is named atom (actual fn) THEN + get function from property list of actual fn + or from functional alist entry + ELIF atom (actual fn) THEN + error stop ("Eine Funktion darf kein unbenanntes Atom sein") + ELSE + IF eq (head (actual fn), lambda constant) THEN + LEAVE reduce actual fn to lambda expression + ELIF eq (head (actual fn), label constant) THEN + get function from label expression and update alist + ELSE + error stop ("Funktion ist weder Atom noch LAMBDA-/LABEL-Ausdruck") + FI + FI + PER. + +get function from property list of actual fn or from functional alist entry: + IF property exists (actual fn, function constant) THEN + get function from property list of actual fn + ELSE + get function from functional alist entry + FI. + +get function from property list of actual fn: + actual fn := property (actual fn, function constant). + +get function from functional alist entry: + SYM VAR actual alist entry; + begin alist retrieval; + REP + IF end of alist THEN + error stop ("Die Funktion " + name (actual fn) + + " ist nicht definiert") + FI; + search for next functional alist entry; + UNTIL eq (head (actual functional alist entry), actual fn) PER; + actual fn := tail (actual functional alist entry). + +get function from label expression and update alist: + actual fn := tail (actual fn); + IF atom (actual fn) COR + (NOT atom (head (actual fn)) OR atom (tail (actual fn))) COR + NOT null (tail (tail (actual fn))) THEN + error stop ("Ungueltiger LABEL-Ausdruck") + FI; + SYM VAR new alist entry; + prepare new functional alist entry; + set head (new alist entry, head (actual fn)); + actual fn := head (tail (actual fn)); + set tail (new alist entry, actual fn). + +insert parameter evaluated argument pairs in reversed order in new alist: + actual fn := tail (actual fn); + IF atom (actual fn) THEN + error stop ("Ungueltiger LAMBDA-Ausdruck") + FI; + SYM VAR parameter list rest :: head (actual fn), + argument list rest :: argument list; + actual fn := tail (actual fn); + WHILE NOT null (parameter list rest) REP + add next parameter argument pair to alist + PER; + check wether no arguments are left over. + +add next parameter argument pair to alist: + IF atom (parameter list rest) THEN + error stop ("Parameterliste endet falsch") + FI; + SYM VAR param pointer :: head (parameter list rest); + parameter list rest := tail (parameter list rest); + IF is named atom (param pointer) AND NOT null (param pointer) THEN + add parameter evaluated argument pair to alist; + advance argument list rest + ELIF atom (param pointer) THEN + error stop ("Unbenannte Atome und NIL koennen nicht Parameter sein") + ELSE + IF eq (head (param pointer), indefinite constant) THEN + check wether is last param; + advance param pointer; + IF eq (head (param pointer), quote constant) THEN + advance param pointer; + move param pointer to parameter; + add parameter indefinite quoted argument pair to alist + ELSE + move param pointer to parameter; + add parameter indefinite evaluated argument pair to alist + FI; + argument list rest := nil + ELIF eq (head (param pointer), quote constant) THEN + advance param pointer; + move param pointer to parameter; + add parameter quoted argument pair to alist; + advance argument list rest + ELIF eq (head (param pointer), function constant) THEN + advance param pointer; + move param pointer to parameter; + add parameter functional argument pair to alist; + advance argument list rest + ELSE + error stop ("Ungueltiger Parameter") + FI + FI. + +advance param pointer: + param pointer := tail (param pointer); + IF atom (param pointer) THEN + error stop ("Ungueltiger Parameter") + FI. + +move param pointer to parameter: + IF NOT null (tail (param pointer)) THEN + error stop ("Ungueltiger Parameter") + FI; + param pointer := head (param pointer); + IF NOT atom (param pointer) OR null (param pointer) THEN + error stop ("Unbenannte Atome und NIL koennen nicht Parameter sein") + FI. + +advance argument list rest: + argument list rest := tail (argument list rest). + +add parameter evaluated argument pair to alist: + prepare new alist entry; + set head (new alist entry, param pointer); + set tail (new alist entry, x eval (actual argument, alist)). + +check wether is last param: + IF NOT null (parameter list rest) THEN + error stop ("Ein INDEFINITE-Parameter muss der letzte sein") + FI. + +add parameter indefinite quoted argument pair to alist: + prepare new alist entry; + set head (new alist entry, param pointer); + set tail (new alist entry, argument list rest); + WHILE NOT atom (argument list rest) REP + argument list rest := tail (argument list rest) + PER; + IF NOT null (argument list rest) THEN + error stop ("Argumentliste endet falsch") + FI. + +add parameter indefinite evaluated argument pair to alist: + prepare new alist entry; + set head (new alist entry, param pointer); + last evaluated argument := new alist entry; + WHILE NOT atom (argument list rest) REP + set tail (last evaluated argument, + cons (x eval (head (argument list rest), alist), nil)); + last evaluated argument := tail (last evaluated argument); + advance argument list rest + PER; + IF NOT null (argument list rest) THEN + error stop ("Argumentliste endet falsch") + FI. + +last evaluated argument: + param pointer. +(* The value of param pointer is not used further, so the *) +(* variable can be "reused" in this manner. *) + +add parameter quoted argument pair to alist: + prepare new alist entry; + set head (new alist entry, param pointer); + set tail (new alist entry, actual argument). + +add parameter functional argument pair to alist: + prepare new functional alist entry; + set head (new alist entry, param pointer); + set tail (new alist entry, actual argument). + +actual argument: + IF atom (argument list rest) THEN + IF null (argument list rest) THEN + error stop ("Zuwenig Argumente") + ELSE + error stop ("Argumentliste endet falsch") + FI + FI; + head (argument list rest). + +check wether no arguments are left over: + IF NOT null (argument list rest) THEN + error stop ("Zuviele Argumente") + FI. + +function body evaluation: + IF is int pair (actual fn) THEN + predefined function evaluation + ELIF atom (actual fn) COR NOT null (tail (actual fn)) THEN + error stop ("Ungueltiger LAMBDA-Ausdruck"); nil + ELSE + x eval (head (actual fn), new alist) + FI. + +predefined function evaluation: + SELECT int 1 (actual fn) OF + CASE 0: call eval cond + CASE 1: call begin oblist dump + CASE 2: call next atom + CASE 3: call add property + CASE 4: call alter property + CASE 5: call delete property + CASE 6: call property exists + CASE 7: call property + CASE 8: call add flag + CASE 9: call flag + CASE 10: call delete flag + CASE 11: call begin property list dump + CASE 12: call next property + CASE 13: call apply + CASE 14: call eval + CASE 15: call try + CASE 16: give association list + CASE 17: call error stop + CASE 18: call head + CASE 19: call set head + CASE 20: call tail + CASE 21: call set tail + CASE 22: call cons + CASE 23: call eq + CASE 24: call get sym + CASE 25: call put sym + CASE 26: call null + CASE 27: call is atom + CASE 28: call is named atom + CASE 29: call get named atom + CASE 30: call put named atom + CASE 31: call is text + CASE 32: call get text + CASE 33: call put text + CASE 34: call is character + CASE 35: call get character + CASE 36: call put character + CASE 37: call is int + CASE 38: call get int + CASE 39: call put int + CASE 40: call sum + CASE 41: call difference + CASE 42: call product + CASE 43: call quotient + CASE 44: call remainder + CASE 45: call equal + CASE 46: call trace + CASE 47: call define + CASE 48: call set + OTHERWISE error stop("Es gibt (noch) keine LISP-Funktion mit der Nummer" + + text (int 1 (actual fn)) ); nil + END SELECT. + +call eval cond: + x eval condition (arg 1, alist). + +call begin oblist dump: + begin oblist dump; nil. + +call next atom: + next atom. + +call add property: + add property (arg 3, arg 2, arg 1); arg 1. + +call alter property: + alter property (arg 3, arg 2, arg 1); arg 1. + +call delete property: + delete property (arg 2, arg 1); nil. + +call property exists: + IF property exists(arg 2,arg 1) THEN true constant ELSE false constant FI. + +call property: + property (arg 2, arg 1). + +call add flag: + add flag (arg 2, arg 1); nil. + +call flag: + IF flag (arg 2, arg 1) THEN true constant ELSE false constant FI. + +call delete flag: + delete flag (arg 2, arg 1); nil. + +call begin property list dump: + begin property list dump (arg 1); nil. + +call next property: + SYM VAR s1, s2; next property (s1, s2); cons (s1, s2). + +call apply: + x apply (arg 3, arg 2, arg 1). + +call eval: + x eval (arg 2, arg 1). + +call try: + x try (arg 4, arg 3, arg 2, arg 1). + +give association list: + alist. + +call error stop: + error stop (text (arg 1)); nil. + +call head: + head (arg 1). + +call set head: + set head (arg 2, arg 1); arg 2. + +call tail: + tail (arg 1). + +call set tail: + set tail (arg 2, arg 1); arg 2. + +call cons: + cons (arg 2, arg 1). + +call eq: + IF eq (arg 2, arg 1) THEN true constant ELSE false constant FI. + +call get sym: + get (s1); s1. + +call put sym: + put (arg 1); arg 1. + +call null: + IF null (arg 1) THEN true constant ELSE false constant FI. + +call is atom: + IF atom (arg 1) THEN true constant ELSE false constant FI. + +call is named atom: + IF is named atom (arg 1) THEN true constant ELSE false constant FI. + +call get named atom: + TEXT VAR t; get (t); new atom (t). + +call put named atom: + put (name (arg 1)); arg 1. + +call is text: + IF is text (arg 1) THEN true constant ELSE false constant FI. + +call get text: + get (t); sym (t). + +call put text: + put (text (arg 1)); arg 1. + +call is character: + IF is character (arg 1) THEN true constant ELSE false constant FI. + +call get character: + inchar (t); sym character (code (t)). + +call put character: + out (code (character (arg 1))); arg 1. + +call is int: + IF is int pair (arg 1) THEN true constant ELSE false constant FI. + +call get int: + INT VAR i; get (i); sym (i, -1). + +call put int: + put (int 1 (arg 1)); arg 1. + +call sum: + sum (arg 1). + +call difference: + difference (arg 2, arg 1). + +call product: + product (arg 1). + +call quotient: + quotient (arg 2, arg 1). + +call remainder: + remainder(arg 2, arg 1). + +call equal: + IF equal (arg 2, arg 1) THEN true constant ELSE false constant FI. + +call trace: + trace := NOT trace; + IF trace THEN true constant ELSE false constant FI . + +call define: (*hey*) + define (arg 1) . + +call set: (*hey*) + add property (new atom ( name (arg 2)), apval constant, arg 1); arg 1 . + +arg 1: + tail (head (new alist)). + +arg 2: + tail (head (tail (new alist))). + +arg 3: + tail (head (tail (tail (new alist)))). + +arg 4: + tail (head (tail (tail (tail (new alist))))). + +END PROC x apply; + +SYM PROC define (SYM CONST x): (*hey*) + IF eq (x, nil) THEN nil + ELSE add property (new atom (name (head (head (x)))), + function constant, tail (head (x)) ); + cons (head (head (x)), define (tail (x)) ) + FI . +END PROC define; + +SYM VAR old alist :: nil; + +SYM PROC eval (SYM CONST expression, alist): + enable stop; + initialize constants; + x eval (expression, alist) +END PROC eval; + + +SYM PROC x eval (SYM CONST expression, alist): (*hey*) + IF trace THEN line; + put ("e v a l :"); put (expression); line; + IF NOT equal (alist, old alist) THEN + put ("bindings :"); old alist := alist; put (alist); line FI + FI; + IF atom (expression) THEN + IF is named atom (expression) THEN + value from property list of expression or from alist entry + ELSE + expression + FI + ELSE + x apply (head (expression), tail (expression), alist) + FI. + +value from property list of expression or from alist entry: + IF property exists (expression, apval constant) THEN + value from property list of expression + ELSE + value from alist entry + FI. + +value from property list of expression: + property (expression, apval constant). + +value from alist entry: + SYM VAR actual alist entry; + begin alist retrieval; + REP + IF end of alist THEN + error stop ("Das Atom " + name (expression) + " hat keinen Wert") + FI; + search for next alist entry + UNTIL eq (head (actual alist entry), expression) PER; + tail (actual alist entry). + +END PROC x eval; + + +SYM PROC try (SYM CONST expression list, alist, + error output, break possible): + enable stop; + initialize constants; + x try (expression list, alist, error output, break possible) +END PROC try; + + +SYM PROC x try (SYM CONST expression list, alist, + error output, break possible): + BOOL CONST output :: bool (error output), + halt enabled :: bool (break possible); + SYM VAR expr list rest :: expression list; + REP + IF null (expr list rest) THEN + LEAVE x try WITH nil + ELIF atom (expr list rest) THEN + error stop ("Ausdrucksliste fuer 'try' endet falsch") + ELSE + try evaluation of actual expression + FI; + expr list rest := tail (expr list rest) + PER; + nil. + +try evaluation of actual expression: + disable stop; + SYM VAR result :: x eval (head (expr list rest), alist); + IF is error THEN + IF error message = "halt from terminal" AND halt enabled THEN + enable stop + ELIF output THEN + put error + FI; + add property (errors, apval constant, sym (error message)); + clear error + ELSE + LEAVE x try WITH result + FI; + enable stop. + +END PROC x try; + + +SYM PROC x eval condition (SYM CONST pair list, alist): + enable stop; + SYM VAR cond pair list rest :: pair list; + REP + IF atom (cond pair list rest) THEN + error stop ("Keine 'T'-Bedingung in bedingtem Ausdruck gefunden") + FI; + check wether is correct pair; + IF true condition found THEN + LEAVE x eval condition WITH x eval (head (tail (actual pair)), alist) + FI; + cond pair list rest := tail (cond pair list rest) + PER; + nil. + +check wether is correct pair: + IF atom (actual pair) COR + atom (tail (actual pair)) COR + NOT null (tail (tail (actual pair))) THEN + error stop ("Ungueltiges Paar im bedingten Ausdruck") + FI. + +true condition found: + bool (x eval (head (actual pair), alist)). + +actual pair: + head (cond pair list rest). + +END PROC x eval condition; + + +BOOL PROC bool (SYM CONST sym): + IF eq (sym, true constant) THEN + TRUE + ELIF eq (sym, false constant) THEN + FALSE + ELSE + error stop ("'T' oder 'F' erwartet"); TRUE + FI +END PROC bool; + + +(******* a-list handling refinements used in 'x apply' and 'x eval' *******) + +(* declared within 'x apply' and 'x eval': 'actual alist entry' *) + +. + +initialize for alist insertion: + new alist := alist. + +begin alist retrieval: + SYM VAR actual alist pos :: alist. + +search for next alist entry: + WHILE NOT end of alist REP + IF atom (actual alist pos) THEN + error stop ("Bindeliste endet falsch") + FI; + actual alist entry := head (actual alist pos); + actual alist pos := tail (actual alist pos); + UNTIL is non functional alist entry PER. + +is non functional alist entry: + NOT is functional alist entry. + +search for next functional alist entry: + WHILE NOT end of alist REP + IF atom (actual alist pos) THEN + error stop ("Bindeliste endet falsch") + FI; + actual alist entry := head (actual alist pos); + actual alist pos := tail (actual alist pos); + UNTIL is functional alist entry PER; + actual alist entry := tail (actual alist entry). + +is functional alist entry: + check wether is alist entry; + null (head (actual alist entry)). + +check wether is alist entry: + IF atom (actual alist entry) THEN + error stop ("Bindelisteneintrag ist kein Paar") + FI. + +end of alist: + null (actual alist pos). + +actual functional alist entry: + actual alist entry. + +prepare new alist entry: + new alist := cons (cons (nil, nil), new alist); + new alist entry := head (new alist). + +prepare new functional alist entry: + new alist := cons (cons (nil, cons (nil, nil)), new alist); + new alist entry := tail (head (new alist)). + + +END PACKET lisp interpreter; + + + diff --git a/lang/lisp/1.8.7/src/lisp.4 b/lang/lisp/1.8.7/src/lisp.4 new file mode 100644 index 0000000..0733dcd --- /dev/null +++ b/lang/lisp/1.8.7/src/lisp.4 @@ -0,0 +1,143 @@ +PACKET lisp (* Autor: J.Durchholz , P. Heyderhoff *) + (* Datum: 09.05.1984 *) + DEFINES (* Version 1.7.2 *) + (* Änderung: notebook *) + (* 13.3.86 I. Ley *) + (* Änderung: start lisp system *) + (* 25.3.86 I. Ley *) + (* Anpassung an ELAN-Compiler Version 1.7.5 *) + (* 8.4.86 I. Ley *) + start lisp system, + lisp heap, + insert lisp, + run lisp, + run lisp again, + lisp, + break lisp: + +SYM VAR run again pointer :: nil; +DATASPACE VAR insert heap :: nil space; + +PROC start lisp system (DATASPACE CONST heap): + enable stop; + initialize lisp system (heap); + forget (insert heap); + insert heap := heap +END PROC start lisp system; + + +PROC start lisp system (DATASPACE CONST heap, FILE VAR f): + enable stop; + create lisp system (f, heap); + forget (insert heap); + insert heap := heap +END PROC start lisp system; + + +PROC start lisp system (FILE VAR f): + create lisp system (f, insert heap) +END PROC start lisp system; + + +DATASPACE PROC lisp heap: + insert heap +END PROC lisp heap; + + +DATASPACE VAR run heap :: nil space; + + +PROC insert lisp: + insert lisp (last param) +END PROC insert lisp; + + +PROC insert lisp (TEXT CONST file name): + interpret (insert heap, file name) +END PROC insert lisp; + + +PROC run lisp: + run lisp (last param) +END PROC run lisp; + + +PROC run lisp (TEXT CONST file name): + forget (run heap); + run heap := insert heap; + interpret (run heap, file name) +END PROC run lisp; + + +PROC interpret (DATASPACE CONST heap, TEXT CONST file name): + enable stop; + FILE VAR f :: sequential file (input, file name); + interpret (heap, f) +END PROC interpret; + + +PROC interpret (DATASPACE CONST heap, FILE VAR f): + initialize lisp system (heap); + get (f, run again pointer); + add property (new atom ("program"), new atom ("APVAL"), run again pointer); + put (evalquote (run again pointer)) +END PROC interpret; + +PROC run lisp again: + put (evalquote (run again pointer)) +END PROC run lisp again; + + +PROC get ausdruck: + enable stop; get (ausdruck) +END PROC get ausdruck; + +SYM VAR ausdruck; + +PROC lisp: + +(* HAUPT TESTPROGRAMM FUER LISP Heyderhoff 25.1.83 *) +IF NOT exists ("LISP HEAP") THEN + FILE VAR bootstrap :: sequential file (input, "lisp.bootstrap"); + create lisp system (bootstrap, new ("LISP HEAP")); + verbose lisp output (TRUE); +FI; +SYM VAR work; +command dialogue(FALSE); forget ("LISP INPUT"); command dialogue(TRUE); +(* bildlaenge(23); *) (* EUMEL 1.65 *) +disable stop; +REP + get (ausdruck); + IF is error THEN + handle error + ELSE + work := evalquote (ausdruck); + IF is error THEN handle error + ELSE note (work) + FI + FI +PER . + +handle error: + IF text (error message, 18) = "halt from terminal" THEN + enable stop + ELSE + note (error message); + put ( error message); pause(20); + clear error; + FI . +END PROC lisp; + +PROC break lisp: + break; + page; + quit; + FILE VAR in :: sequential file (modify, "LISP INPUT"), + out :: notefile; modify (out); + headline (out,"LISP OUTPUT"); + headline (in, "LISP INPUT"); + noteedit (in); +END PROC break lisp + +END PACKET lisp; + diff --git a/lang/lisp/1.8.7/src/lisp.bootstrap b/lang/lisp/1.8.7/src/lisp.bootstrap new file mode 100644 index 0000000..37efbde --- /dev/null +++ b/lang/lisp/1.8.7/src/lisp.bootstrap @@ -0,0 +1,118 @@ +NIL APVAL +NIL +T APVAL +T +F APVAL +F +COND FUNCTION +(LAMBDA ((INDEFINITE QUOTE X)) . 0) +BEGINOBLISTDUMP FUNCTION +(LAMBDA () . 1) +NEXTATOM FUNCTION +(LAMBDA () . 2) +ADDPROPERTY FUNCTION +(LAMBDA (X X X) . 3) +ALTERPROPERTY FUNCTION +(LAMBDA (X X X) . 4) +DELETEPROPERTY FUNCTION +(LAMBDA (X X) . 5) +PROPERTYEXISTS FUNCTION +(LAMBDA (X X) . 6) +PROPERTY FUNCTION +(LAMBDA (X X) . 7) +ADDFLAG FUNCTION +(LAMBDA (X X) . 8) +FLAG FUNCTION +(LAMBDA (X X) . 9) +DELETEFLAG FUNCTION +(LAMBDA (X X) . 10) +BEGINPROPERTYLISTDUMP FUNCTION +(LAMBDA (X) . 11) +NEXTPROPERTY FUNCTION +(LAMBDA () . 12) +APPLY FUNCTION +(LAMBDA (X X X) . 13) +EVAL FUNCTION +(LAMBDA (X X) . 14) +TRY FUNCTION +(LAMBDA (X X X X) . 15) +ASSOCIATIONLIST FUNCTION +(LAMBDA () . 16) +ERRORSTOP FUNCTION +(LAMBDA (X) . 17) +HEAD FUNCTION +(LAMBDA (X) . 18) +SETHEAD FUNCTION +(LAMBDA (X X) . 19) +TAIL FUNCTION +(LAMBDA (X) . 20) +SETTAIL FUNCTION +(LAMBDA (X X) . 21) +CONS FUNCTION +(LAMBDA (X X) . 22) +EQ FUNCTION +(LAMBDA (X X) . 23) +GET FUNCTION +(LAMBDA () . 24) +PUT FUNCTION +(LAMBDA (X) . 25) +NULL FUNCTION +(LAMBDA (X) . 26) +ATOM FUNCTION +(LAMBDA (X) . 27) +NAMEDATOM FUNCTION +(LAMBDA (X) . 28) +GETATOM FUNCTION +(LAMBDA () . 29) +PUTATOM FUNCTION +(LAMBDA (X) . 30) +TEXT FUNCTION +(LAMBDA (X) . 31) +GETTEXT FUNCTION +(LAMBDA () . 32) +PUTTEXT FUNCTION +(LAMBDA (X) . 33) +CHARACTER FUNCTION +(LAMBDA (X) . 34) +GETCHARACTER FUNCTION +(LAMBDA () . 35) +PUTCHARACTER FUNCTION +(LAMBDA (X) . 36) +INT FUNCTION +(LAMBDA (X). 37) +GETINT FUNCTION +(LAMBDA () . 38) +PUTINT FUNCTION +(LAMBDA (X) . 39) +SUM FUNCTION +(LAMBDA ((INDEFINITE X)) . 40) +DIFFERENCE FUNCTION +(LAMBDA (X X). 41) +PRODUCT FUNCTION +(LAMBDA ((INDEFINITE X)). 42) +QUOTIENT FUNCTION +(LAMBDA (X X).43) +REMAINDER FUNCTION +(LAMBDA (X X).44) +EQUAL FUNCTION +(LAMBDA (X X) . 45) +TRACE FUNCTION +(LAMBDA () . 46 ) +DEFINE FUNCTION +(LAMBDA ((INDEFINITE X)) . 47 ) +SET FUNCTION +(LAMBDA (X X) . 48 ) +QUOTE FUNCTION +(LAMBDA ((QUOTE X)) X) +LIST FUNCTION +(LAMBDA ((INDEFINITE X)) X) +DO FUNCTION +(LAMBDA ((INDEFINITE X)) NIL) +PUTLIST FUNCTION +(LAMBDA ((INDEFINITE X)) + (COND + ((NULL X) NIL) + (T (DO (PUT (HEAD X)) (PUTLIST (TAIL X)))) + ) +) + diff --git a/lang/prolog/1.8.7/doc/prolog handbuch b/lang/prolog/1.8.7/doc/prolog handbuch new file mode 100644 index 0000000..ea7c6a5 --- /dev/null +++ b/lang/prolog/1.8.7/doc/prolog handbuch @@ -0,0 +1,581 @@ +____________________________________________________________________________ + + +#on("b")##on ("u")# +#center#Betriebssystem E U M E L +#off ("u")# + + +#center#Prolog + + + + +#off("b")# +#center#Lizenzfreie Software der +#on ("b")# + +#center#Gesellschaft für Mathematik und Datenverarbeitung mbH, +#center#5205 Sankt Augustin + + +#off("b")# +#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für +#center#nichtkommerzielle Zwecke gestattet. + +#center#Gewährleistung und Haftung werden ausgeschlossen + + +____________________________________________________________________________ +#page# + +Dr.P.Heyderhoff 12.03.1987 +GMD.F2.G2 + + + + + + + E L A N - P R O L O G + _____________________ + + (Die Fachsprache der künstlichen Intelligenz) + +#on("u")#Benutzungsanleitung und technische Beschreibung#off("u")# + + +Elan-Prolog ist eine Computersprache der fünften Generation, die für +die Praxis der Programmierung und die Lehre in Informatik eine neue +Dimension erschließt. Für den professionellen Programmierer eröffnet sie +neue Möglichkeiten, mächtige Anwendungen, wie Expertensysteme und andere +neuartige Systeme der Wissensverarbeitung zu entwickeln. + +Elan-Prolog unterscheidet sich grundsätzlich von üblichen konventionellen +Programmiersprachen. In Sprachen wie Elan und Pascal muß der Programmierer +genau angeben, wie ein gewünschtes Ergebnis errechnet werden soll. Um was es +sich dabei handelt, steht bestenfalls dann in der Dokumentation. Ganz anders +ist es in Prolog. PROLOG steht für PROgrammieren in LOgik und basiert auf +dem Prädikaten-Kalkül, der bekanntesten Form der formalen Logik. Also in +Prolog schreibt der Programmierer hin, worin das Problem besteht. Er bedient +sich dabei dieser formalen Logik. Prolog versucht dann eine Lösung zu +finden. Der Lösungsweg ist dabei im Programm nicht vorgeschrieben. Das +entlastet den Programmierer, und er kann seine ganze Kraft auf die logische +Beschreibung des Problems konzentrieren. + +Elan-Prolog ist ein interpretatives System, das voll kompatibel ist mit dem +Edinburgh Standard Prolog und in in komfortabler Weise in das Betriebssystem +Eumel eingebettet ist. + +Eigenschaftes von Elan-Prolog: + +- Syntax gemäß dem Edinburgh Standard Prolog nach Clocksin-Mellish + +- Interpretierendes System mit inkrementellem Einpass-Compiler + +- Interaktiver Mehrfenster-Texteditor des Eumelsystems + +- Zugriff auf Elan-Prozeduren als Prolog-Regeln + +- Geschwindigkeit ca. 100 LIPS auf IBM/PC-XT + +- optionale dynamische Ablaufverfolgung + +- Erklärungskomponente + +- Eingabe und Ausgabe von Prolog-Ausdrücken und Klartext + +- Programmiert und dokumentiert in ELAN (über 2000 Zeilen) + +- daher besonders für den Informatik-Unterricht geeignet +#page# +#on("u")#Beschränkungen des Elan-Prolog:#off("u")# + +Folgende Beschränkungen gelten für die Implementierung von Elan-Prolog im +Eumel-Systems: + +- Maximal 16000 Fakten und Regeln + +- Maximal 16000 Terme zur Konstruktion von Ausdrücken, Listen und Regeln + +- Maximal 800 Variablenbindungen + +- Maximal 800 Einträge im Beweisbaum + +- Maximal 4000 Bezeichner für Atome und Variablen + +- Maximal 16000 Buchstaben für alle Bezeichner zusammen + + +Wie sieht ein Prolog-Programm aus? + +Ein Prolog-Programm besteht aus + + - Fakten über Objekte und ihre Beziehungen + + - Regeln über Objekte und ihre Beziehungen + +und besonders wichtig: + + - Der Benutzer kann Prolog über die Fakten und Regeln ausfragen. + +Fakten aus einer Wissensbasis, nämlich dem Prolog-Programm, sind z.B.: + + enthaelt (wisky, aethanol). + +Das wird gelesen als: "Wisky enthält Aethanol.". Grundzüge der sehr +einfachen Syntax lassen sich hieran erklären. Ein Faktum wird geschrieben +wie in diesem Beispiel: + + - Erst kommt der Name der Relation, geschrieben wie ein Elan-Name in + kleinen Buchstaben. + + - Dann folgt in runden Klammern und durch Kommata getrennt eine Liste + von Objektnamen. + + - Zum Schluß steht ein Punkt. + +Regeln sind Problembeschreibungen in der Form von logischen Ausdrücken der +symbolischen Logik, wie z.B. die folgende Regel: + + bewirkt (A, B, kopfschmerz) :- enthaelt (A, aethanol), + enthaelt (B, aspirin ). + +Das wird gelesen als: "Wenn man eine Droge A, die Aethanol enthält, +und eine Droge B, die Aspirin enthält gleichzeitig einnimmt, dann bewirkt +das Kopfschmerzen." Wie man sieht werden logische Variablen mit großen +Buchstaben (wie Elan-Operatoren) geschrieben. Das Zeichen ":-" steht für das +logische Wenn, und das Komma(",") für die logische Konjunktion. Die logische +Disjunktion wird durch Semikolon(";") ausgedrückt. +#page# +Neben der hiermit vorgestellten Prefix-Schreibweise für Relationen gibt es in +ELAN-Prolog auch noch eine Infix-Schreibweise für zweistellige Relationen. +Hierbei werden die Relationen als Infix-Operatoren in großen +Buchstaben geschrieben (wie in ELAN) und zwischen die beiden Operanden +gesetzt. Als Operatoren sind auch die in Elan üblichen Operatoren + + ( +, -, *, /, MOD, =, <, >, <=, >=, <> ) +zulässig. + +In Infixausdrücken (wie z.B. 2+3*4) gelten die bekannten Vorrangregeln. Auch +Klammern sind zulässig. Selbstdefinierte Operatoren haben niedrigste +Priorität. + +Obiges Beispiel in Infix-Schreibweise: + + wisky ENTHAELT aethanol. + + bewirkt (A, B, kopfschmerz) :- A ENTHAELT aethanol, + B ENTHAELT aspirin. + + +Objekte in Prolog können Atome oder Listen sein. Für Atome gibt es zwei +Schreibweisen: + + - genau so wie Elan-Bezeichner, also bestehend aus kleinen Buchstaben + und Blanks. Dabei werden die Blanks eliminiert. + + - genauso wie Elan-Texte, nämlich in Gänsefüßchen eingeschlossen. + +Für Listen von Objekten gibt es wiederrum zwei Schreibweisen, wie folgende +zwei unterschiedlichen Notationen des gleichen Beispiels zeigen: + + - [ das, ist, [ zum, beispiel ], eine, liste ] + + - [ das, ist, [ zum | [ beispiel | [] ] ], eine, liste ] + +Im zweiten Fall ist die als drittes Element in der Gesamtlisten enthaltene +Teilliste mit dem Konstruktor "|" und der leeren Liste "[]" zusammengesetzt. +Die Grundoperationen, die aus der Programmiersprache LISP bekannt sind, +können als Prolog-Fakten unmittelbar wie folgt definiert werden: + + eq (X, X). + head ([X|Y], X). + tail ([X|Y], Y). + cons (X, Y, [X|Y]). +#page# +#on("u")#Standard - Operatoren von Elan-Prolog:#off("u")# + +Im System sind nur ganz wenige Standardoperatoren eingebaut. Es sind die +folgenden Fakten: + + - ! . der CUT-Operator schaltet des Backtracking ab. + + - bye. beendet die prolog Anwendung. + + - listing. zeigt alle insertierten Regeln. + + - listing (X). zeigt alle insertierten Regeln über X. + + - call (X). X wird ausgeführt. + + - write (X). das an X gebundenen Prolog-Objekts wird ausgegeben, + writeq (X). und wenn nicht eindeutig, gequotet, + put (X). das Zeichen, dessen ASCII-Code X ist wird ausgegeben, + name (X,[Y]). unifiziert das Atom X mit der Liste seiner Buchstaben. + + - read (X). ein Objekt wird gelesen und an die Variable gebunden. + get0 (X). das nächste Zeichen wird gelesen, + get (X). das nächste druckbare Zeichen wird gelesen, + + - X = Y . Die an X und Y gebundenen Objekte sind gleich, + X <> Y . sie sind ungleich, + X <= Y . sie sind kleiner oder gleich, + X == Y . sie sind wörtlich gleich, + X =.. [F|A] . X ist der Term mit Funktor F und Argumentliste A. + + - X + Y . sie sollen addiert, + X - Y . subtrahiert, + X * Y . multipliziert, + X / Y . dividiert, + X MOD Y . der Divisionsrest soll ermittelt werden, + die Auswertung geschieht durch den 'is'-Operators. + + - X IS EXPR . Das Ergebnis des arithmetischen Ausdrucks EXPR wird + gebildet und mit X unifiziert. + + - incr (X). der arithmetische Wert von X wird um eins erhöht. + + - assertz ([X]). insertiert die Regel X am Ende einfügend. + asserta ([Χ]). insertiert die Regel X am Anfang einfügend. + retract ([X]). entfernt die Regel X wieder. + clause (X,[Y]). holt die Regel Y mit dem Kopf X aus der Knowledgebase. + + - functor (X,Y,Z) Y ist der Funktor von X und Z ist seine Arität. + arg (X,Y,Z). Z ist das x-te Argument der Funktion Y. + + - elan (X). Ausführung der insertierten ELAN-Prozedur X + elan (X,Y). Ausführung von X mit dem TEXT-CONST-Parameter Y + + - elan(trace,on). schaltet den dynamischen Ablaufverfolger ein und + elan(trace,off) schaltet ihn wieder ab. + + - elan(consult,X) lädt das Prologprogramm aus der Datei namens X hinzu. + elan(reconsult,X) ersetzt das Prologprogramm aus der Datei X. + elan(abolish,X) entfernt alle Regeln mit dem Namen X. +#page# +#on("u")#Das Dialogverhalten von Elan-Prolog:#off("u")# + +Elan-Prolog wird, sobald es in das Eumel-System insertiert ist, als Prozedur +mit dem Namen "prolog" und einem optionalen TEXT-Parameter aufgerufen. Der +Textparameter enthält den Namen einer Datei, die ein Prolog-Programm enthält, +das geladen werden soll. Fehlt der Parameter, wird, wie üblich, die zuletzt +bearbeitete Datei genommen. Im Prolog-Dialog können später weitere +Prolog-Programme mit der Prozedur namens "consult" hinzugeladen werden. + +Also +einfachster Aufruf: prolog ("") + +Antwort: ?- +Beispiel-Eingabe: 3 = 3 +Antwort: yes + ?- +Eingabe: 4 = -5 +Antwort: no + ?- + +Besondere Dialogkommandos: + + ?- +Eingabe: ? +Antwort z.B.: 13.5 SEC + ?- +Eingabe: listing +Antwort: { zeigt alle aktuell verfügbaren Regeln } + ?- +Eingabe: {ESCAPE} q +Ausgabe: gib kommando: + +Eingabe: prolog again +Ausgabe: ?- +Eingabe: [sum, permute] {in eckigen Klammern!} + { konsultiert diese beiden Dateien } +Antwort z.B.: 25 rules inserted. + ?- +Eingabe: [-sum, -permute] + { löscht und rekonsultiert aus diesen Dateien } +Antwort z.B.: 25 rules inserted. + +Eingabe: {ESCAPE} {ESCAPE} +Antwort: gib kommado: +Elan-Eingabe z.B.: show ("standard") + { zeigt die Datei dieses Namens } + ?- + +Auf diese Weise können bequem Eumel-Kommandos gegeben werden. Die +Umschaltung vom Prolog- zum Eumelmonitor-Betrieb erfolgt durch die Tasten +{ESCAPE},{ESCAPE} und {RETURN}. Wie üblich ist das zuletzt verwendete +Kommando auch im Prolog-Dialog mit dem Escapekommando "{ESCAPE} k" +wiederzubekommen. Das Kommando "{ESCAPE} q" beendet den Dialog. +#page# +#on("u")#Ausprobieren der Prolog-Programmbeispiele:#off("u")# + +Zum Ausprobieren sind die Prologbeispiele "eq", "permute" und "mann" +beigefügt. + +Beispiel: ?- +Eingabe: [permute] {in eckigen Klammern!} +Antwort: 5 rules inserted. + ?- +Eingabe: marquise(X) +Antwort: beautiful marquise your beautiful eyes make me die of love +Eingabe: {Semicolon} +Antwort: your beautiful eyes beautiful marquise make me die of love + { usw } +Eingabe: {Return} +Antwort: ?- + +Jede #on("u")#Eingabe von Semicolon#off("u")# liefert als Antwort die nächste Permutation. Wenn +eine andere Taste gedrückt wird, bricht die Ausgabe weiterer Ergebnisse ab. + +#on("u")#Eingabe von Fragezeichen#off("u")# liefert neben der Angabe der benötigten +Rechenzeit eine Erklärung der letzten Antwort durch Ausgabe aller zu dieser +Antwort führenden Schlußfolgerungen. Dabei wird der Beweisbaum in Form einer +Einrückstruktur dargestellt. Die Einrückung stellt die Erklärungstiefe dar. + + +#on("u")#Benutzung von Prolog von Elan-Programmen aus#off("u")# + +Wenn man Prolog als Unterprogramm von Elan aus aufrufen will, geht man +folgendermaßen vor: + +1. Laden einer Wissensbasis, + die in einer Datei namens <knowledgebase> z.B."permute" bereitsteht: + + push ("bye"13""); + prolog ("permute"); + + +2. Abfragen an diese Wissensbasis: + + TEXT VAR query, answer; + query:= "marquise (X)"; + IF prolog ( query, answer) + THEN put (answer) + ELSE put ("NO") + FI; + +In diesem Anwendungsbeispiel liefert die Ausgabeanweisung 'put (answer)': + + beautiful marquise your beatiful eyes make me die of love + +#page# +#on("u")#Literatur:#off("u")# + + +1.) W.F.Clocksin, C.S.Mellish: + Programming in Prolog + Springer 1984 + +2.) M.H.van Emden: + An interpreting algorithm for prolog programs + in Implementations of Prolog, Ellis Herwood Ltd, 1984 + +3.) Alain Colmerauer: + Prolog in 10 Figures + Communications of the ACM December 1985 + +4.) J. Cohen: + Describing Prolog by its Interpretation and Compilation + Communications of the ACM December 1985 + +5.) Alain Colmerauer: + Les system q ou un formalisme pour alalyser et synthetiser des phrases + sur ordinateur. + Intern.Rep. 43, Departement d'informatique. Universite de Montreal + Sept. 1970 +#page# +(*************************************************************************) +(* *) +(* Elan-Prolog *) +(* *) +(* Programm-Beispiele: *) +(* *) +(****************** standard (nach Clocksin-Mellish) ********************) + +abolish (X) :- elan (abolish, X). +append ([], X, X) :- !. +append ([X|Y], Z, [X|W]) :- append (Y, Z, W). +atom (X) :- functor (X, Y, 0). +atomic (X) :- atom (X); integer (X). +consult (X) :- elan (consult, X). +end :- bye. +fail :- []. +findall (X, Y, Z) :- tell ("$$"), write ("("), findall (X,Y); + write (")"), told, see ("$$"), read (Z), + seen, elan (forget, "$$"). +findall (X, Y) :- call (Y), writeq (X), write (","), []. +integer (X) :- functor (X, Y, -1). +listing (X). +member (X, [X|Z]). +member (X, [Y|Z]) :- member (X, Z). +nl :- elan (line). +non var (X) :- var (X), !, []; . +not (X) :- call (X), !, []; . +notrace :- elan (trace, off). +reconsult (X) :- elan (reconsult, X). +repeat. +repeat :- repeat. +see (X) :- elan (sysin, X). +seen :- elan (sysin, ""). +tab (X) :- tab(X,1). +tab (X,Y) :- Y<=X, !, put (32), incr(Y), tab(X,Y);. +tell (X) :- elan (sysout, X). +told :- elan (sysout, ""). +trace :- elan (trace, on). +true. +< (X, Y) :- <= (X, Y), <> (X, Y). +> (X, Y) :- <= (Y, X). +>= (X, Y) :- < (Y, X). +#page# +(**************************** sum ***********************************) + +suc (0, 1). suc (1, 2). suc (2, 3). suc (3, 4). suc (4, 5). +suc (5, 6). suc (6, 7). suc (7, 8). suc (8, 9). +sum (0, X, X). +sum (X, Y, Z):- suc (V, X), sum (V, Y, W), suc (W, Z). +plus (X, [0,0], X):- !. +plus (X, Y, Z):- plus one (V, Y), plus (X, V, W), !, plus one (W, Z). +plus one ([X, Y], [V, W]):- suc (Y, W), X = V, !; + Y = 9, suc (X, V), W = 0. +treereverse (X,Y):- rev (X,Y), !; rev (Y,X), !. +rev ([], []). +rev ([X|Y], Z):- X <> [H|T], rev (Y, W), !, append (W, [X], Z); + rev (X, V), rev (Y, W), !, append (W, [V], Z). + +(**************************** permute ************************************) + +permute ([], []). +permute ([E|X], Z):- + permute (X, Y), insert (E, Y, Z). +insert (E, X, [E|X]). +insert (E, [F|X], [F|Y]):- + insert (E, X, Y). +marquise(RESULT):- + permute (["beautiful marquise", + "your beautiful eyes", + "make me", + "die", + "of love" + ], + RESULT). + +(**************************** puzzle ************************************) + + {Solution: 9,5,6,7,0,8,2} +puzzle:- repeat, permute ((9,8,7,6,5,2,0), SENDMORY), + write (SENDMORY), + puzzle (SENDMORY, SEND, MORE, MONEY), + elan (line), + write (SEND), write (+), + write (MORE), write (=), + write (MONEY). + +puzzle([S,E,N,D,O,R,Y], SEND, MORE, MONEY):- + SEND IS ((S * 10 + E) * 10 + N) * 10 + D, + MORE IS ((10 + O) * 10 + R) * 10 + E, + MONEY IS (((10 + O) * 10 + N) * 10 + E) * 10 + Y, + MONEY IS SEND + MORE. + +permute ([], []). +permute ([E|X], Z):- permute (X, Y), insert (E, Y, Z). + +insert (E, X, [E|X]). +insert (E, [F|X], [F|Y]):- insert (E, X, Y). + +repeat. +repeat:- repeat. +#page# +(**************************** prieks ***********************************) + +ist priek (bo priek). +ist priek (ki priek). +ist priek (bla priek). + +WER GNASELT WEN :- population (B), + member ([WEN, WER, _], B), + bedingungen (B). + +WER KNAUDERT WEN:- population (B), + member ([WER, _, WEN], B), + bedingungen (B). + +population (B):- sind prieks (U, V, W), + sind knauderarten (R, S, T), + B = [ [drausla puemfe, U, R], + [glessla puemfe, V, S], + [hapla puemfe, W, T] ]. + +sind prieks (X,Y,Z):- ist priek (G), + ist priek (H), H<>G, + ist priek (I), I<>G, I<>H, !, + permute ([G,H,I], [X,Y,Z]). + +sind knauderarten (X,Y,Z):- ist knauderart (G), + ist knauderart (H), H<>G, + ist knauderart (I), I<>G, I<>H, !, + permute ([G,H,I],[X,Y,Z]). + +ist knauderart (an). +ist knauderart (ab). +ist knauderart (ueber). + +bedingungen (B):- not member ([hapla puemfe,ki priek,_],B) , + not member ([hapla puemfe,_,ueber],B) , + not member ([drausla puemfe,bo priek,_],B) , + not member ([_,bo priek,ab],B) , + noch ne bedingung (B) , + weitere bedingungen (B) , !. + +weitere bedingungen (B):- not member([_,ki priek,ueber],B), + not member([_,bo priek,ueber],B) + ; + member([drausla puemfe,_,an],B). + +noch ne bedingung (B):- not member ([drausla puemfe,ki priek,_],B) + ; + not member ([glessla puemfe,_,ueber],B). + +permute ([], []). +permute (X, [Y|Z]):- delete (Y ,X, E), permute (E, Z). +delete (X, [X|Z], Z). +delete (X, [Y|Z], [Y|E]):- delete (X, Z, E). +member (X, [X|Z]). +member (X, [Y|Z]):- member (X, Z). +not member (X, []). +not member (X, [Y|Z]):- X <> Y, not member (X,Z). +#page# +(**************************** calc ************************************) + +{ CALC evaluates arithmetic expressions with store } + +calc:- eval ([], RS), write (result store), write (RS), nl. + +eval (SI, SO):- + read (CALC), nonvar (CALC), eval member (CALC, SI, SO). + +eval member (CALC, SI, SO):- + member (CALC, [stop,end,bye,eof]), SO=SI; + eval (CALC,I,SI,ST), write (I), eval (ST,SO); + write (error in), write (CALC), nl, eval (SI, SO). + +eval (I, I, S, S):- integer (I). +eval (N, I, S, S):- atom (N), eval atom (N, I, S). + +eval atom (N, I, S):- + member (N=I, S); + write ("error: Cell"), write (N), + write("not found in store. 0 substituted."), nl, I=0. + +eval ( L+R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J+K. +eval ( L-R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J-K. +eval ( L*R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J*K. +eval ( L/R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J/K. + +eval (N=O, I, SI, SO):- + atom (N), eval (O,I,SI,ST), eval repl (N,I,ST,SO). + +eval repl (N, I, [], [=(N,I)]). +eval repl (N, I, [=(N,_)|S], [=(N,I)|S]). +eval repl (N, I, [=(M,J)|SI], [=(M,J)|SO]):- eval repl (N, I, SI, SO). + diff --git a/lang/prolog/1.8.7/source-disk b/lang/prolog/1.8.7/source-disk new file mode 100644 index 0000000..e61107d --- /dev/null +++ b/lang/prolog/1.8.7/source-disk @@ -0,0 +1 @@ +informatikpaket/01_sprachen.img diff --git a/lang/prolog/1.8.7/src/calc b/lang/prolog/1.8.7/src/calc new file mode 100644 index 0000000..0ed11af --- /dev/null +++ b/lang/prolog/1.8.7/src/calc @@ -0,0 +1,32 @@ +{ CALC evaluates arithmetic expressions with store } + +calc:- eval ([], RS), write (result store), write (RS), nl. + +eval (SI, SO):- + read (CALC), nonvar (CALC), eval member (CALC, SI, SO). + +eval member (CALC, SI, SO):- + member (CALC, [stop,end,bye,eof]), SO=SI; + eval (CALC,I,SI,ST), write (I), eval (ST,SO); + write (error in), write (CALC), nl, eval (SI, SO). + +eval (I, I, S, S):- integer (I). +eval (N, I, S, S):- atom (N), eval atom (N, I, S). + +eval atom (N, I, S):- + member (N=I, S); + write ("error: Cell"), write (N), + write("not found in store. 0 substituted."), nl, I=0. + +eval ( L+R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J+K. +eval ( L-R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J-K. +eval ( L*R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J*K. +eval ( L/R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J/K. + +eval (N=O, I, SI, SO):- + atom (N), eval (O,I,SI,ST), eval repl (N,I,ST,SO). + +eval repl (N, I, [], [=(N,I)]). +eval repl (N, I, [=(N,_)|S], [=(N,I)|S]). +eval repl (N, I, [=(M,J)|SI], [=(M,J)|SO]):- eval repl (N, I, SI, SO). + diff --git a/lang/prolog/1.8.7/src/family b/lang/prolog/1.8.7/src/family new file mode 100644 index 0000000..8419cc6 --- /dev/null +++ b/lang/prolog/1.8.7/src/family @@ -0,0 +1,29 @@ + +mann(jürgen). mann(detlef). mann (frank). mann (peter). mann(jochen). +frau(gaby). frau(yvonne). frau(sinha). frau(rita). frau(viktoria). +frau(adelheid). +vater(gaby, peter). vater(yvonne, peter). vater(frank, peter). +mutter(gaby, rita). mutter(yvonne, rita). mutter(frank, rita). +mutter(rita,viktoria). +vater(jürgen, heinz). mutter(jürgen, natalie). +vater(kalle, heinz). mutter(kalle, natalie). +mann(gaby, jürgen). mann(yvonne, detlef). mann(sinha,frank). +mann(rita, peter). mann(adelheid, jochen). +frau(X,Y) :- mann (Y,X). +großmutter(X,Y):- mutter(X,H), mutter(H,Y); vater(X,H), mutter(H,Y). +sohn(X,Y):- vater(Y,X), mann(Y); mutter(Y,X), mann(Y) . +tochter(X,Y):- vater(Y,X), frau(Y); mutter(Y,X), frau(Y). +geschwister(X,Y):-vater(X,A),vater(Y,A),mutter(X,B),mutter(Y,B),<>(X,Y). +bruder(X,Y):- geschwister(X,Y), mann(Y). +schwester(X,Y):- geschwister(X,Y), frau(Y). +schwager(X,Y):- mann(X,Z), bruder(Z,Y); frau(X,Z), bruder(Z,Y). +schwägerin(X,Y):-mann(X,Z),schwester(Z,Y);frau(X,Y),schwester(Z,Y). +freund (X,Y):- mann(Y), mann(X), <>(X,Y); + mann(Y), frau(X), mann(Z,Y), <>(X,Z); + mann(Y), frau(X), !, mann(Z,Y), []; + mann(Y), frau(X). +freundin (X,Y):- frau(Y), frau(X), <>(X,Y); + frau(Y), mann(X), mann(Y,Z), <>(X,Z); + frau(Y), mann(X), !, mann(Y,Z), []; + frau(Y), mann(X). + diff --git a/lang/prolog/1.8.7/src/permute b/lang/prolog/1.8.7/src/permute new file mode 100644 index 0000000..54f8fee --- /dev/null +++ b/lang/prolog/1.8.7/src/permute @@ -0,0 +1,15 @@ +permute ([], []). +permute ([E|X], Z):- + permute (X, Y), insert (E, Y, Z). +insert (E, X, [E|X]). +insert (E, [F|X], [F|Y]):- + insert (E, X, Y). +marquise(RESULT):- + permute (["beautiful marquise", + "your beautiful eyes", + "make me", + "die", + "of love" + ], + RESULT). + diff --git a/lang/prolog/1.8.7/src/prieks b/lang/prolog/1.8.7/src/prieks new file mode 100644 index 0000000..372ec9d --- /dev/null +++ b/lang/prolog/1.8.7/src/prieks @@ -0,0 +1,58 @@ + +ist priek (bo priek). +ist priek (ki priek). +ist priek (bla priek). + +WER GNASELT WEN :- population (B), + member ([WEN, WER, _], B), + bedingungen (B). + +WER KNAUDERT WEN:- population (B), + member ([WER, _, WEN], B), + bedingungen (B). + +population (B):- sind prieks (U, V, W), + sind knauderarten (R, S, T), + B = [ [drausla puemfe, U, R], + [glessla puemfe, V, S], + [hapla puemfe, W, T] ]. + +sind prieks (X,Y,Z):- ist priek (G), + ist priek (H), H<>G, + ist priek (I), I<>G, I<>H, !, + permute ([G,H,I], [X,Y,Z]). + +sind knauderarten (X,Y,Z):- ist knauderart (G), + ist knauderart (H), H<>G, + ist knauderart (I), I<>G, I<>H, !, + permute ([G,H,I],[X,Y,Z]). + +ist knauderart (an). +ist knauderart (ab). +ist knauderart (ueber). + +bedingungen (B):- not member ([hapla puemfe,ki priek,_],B) , + not member ([hapla puemfe,_,ueber],B) , + not member ([drausla puemfe,bo priek,_],B) , + not member ([_,bo priek,ab],B) , + noch ne bedingung (B) , + weitere bedingungen (B) , !. + +weitere bedingungen (B):- not member([_,ki priek,ueber],B), + not member([_,bo priek,ueber],B) + ; + member([drausla puemfe,_,an],B). + +noch ne bedingung (B):- not member ([drausla puemfe,ki priek,_],B) + ; + not member ([glessla puemfe,_,ueber],B). + +permute ([], []). +permute (X, [Y|Z]):- delete (Y ,X, E), permute (E, Z). +delete (X, [X|Z], Z). +delete (X, [Y|Z], [Y|E]):- delete (X, Z, E). +member (X, [X|Z]). +member (X, [Y|Z]):- member (X, Z). +not member (X, []). +not member (X, [Y|Z]):- X <> Y, not member (X,Z). + diff --git a/lang/prolog/1.8.7/src/prolog b/lang/prolog/1.8.7/src/prolog new file mode 100644 index 0000000..7ac2e6a --- /dev/null +++ b/lang/prolog/1.8.7/src/prolog @@ -0,0 +1,2488 @@ +PACKET prolog (* Autor: P.Heyderhoff *) +DEFINES (* Date: 03.07.1987 *) + prolog, prolog again: + +{ GLOBALS } + +LET { Stacksize parameter } + limit = 800; + +LET { nil-POINTER } + nil = 0; + +LET { bootstrap rules } + boot = """|"".""!"".""MOD"".""-"".""+"".""*"".""/"".bye.listing. +call(X).write(X).writeq(X).read(X).get(X).get0(X).put(X).incr(X). +assertz(X).asserta(X).retract(X).var(X). +X IS Y.X=X.X<>Y.X<=Y.X==Y.X=..Y.clause(X,_).name(X,Y). +arg(X,Y,Z).functor(X,Y,Z).elan(X).elan(X,Y)"; + +LET { bootstrap symbols, see: boot } + cons=1, cut=2, mod=3, {TOKEN: minus=4, plus=5, times=6, slash=7} + bye=8, list=9, call=10, xpar=11, + writ=12, wriq=13, read=14, get=15, get0=16, put0=17, + incr=18, ass=19, assa=20, retr=21, vari=22, + is=23, ypar=24, dif=26, leq=27, eq=28, univ=29, clau=30, claupar=31, + nam=32, argi=33, zpar=34, func=35, + elan=36, build ins=33; + +LET { TOKENS } + stroke=1, exclamation=2, colon=3, minus=4, plus=5, times=6, slash=7, + underscore=8, less=9, equal=10, uneq=11, grt=12, eqeq=13, + eqdotdot=14, period=15, comma=17, semicolon=18, + open paren=19, close paren=20, open bracket=21, close bracket=22, + end of input=23, boldvar=24, number=25, identifier=26; + +LET { SYMBOLTYPES } + tag=1, bold=2, num=3, tex=4, operator=5, delimiter=6, end of file=7, + within com=8, within tex=9; + +INT CONST integer:= -1, var:= -2; + +LET TOKEN = INT; + +LET SYMBOLTYPE = INT; + +LET SYMBOL = INT; +LET SYMBOLTABLE = THESAURUS; + +LET TERMS = INT; +{ LET TERMSCELL = STRUCT (TERM first, + TERMS rest); } +LET TERM = STRUCT (SYMBOL symbol, + TERMS arguments, + INT arity); + +LET CLAUSES = INT; +{ LET CLAUSESCELL = STRUCT (TERMS first, + CLAUSES rest); } +LET FRAME = INT; +LET FRAMECELL = STRUCT (TERM call, + FRAME father, + TERMS subgoals, { remaining } + ENVIRONMENT environment, + EXPRESSIONS reset, + CLAUSES rest { potential rules }, + FRAME level ); + +LET ENVIRONMENT = INT; +LET ENVIRONMENTCELL = STRUCT (SUBSTITUTION first, + ENVIRONMENT rest); +LET SUBSTITUTION = STRUCT (TERM variable, + TERM substitute, + FRAME others); + +LET FRAMESTACK = STRUCT (FRAME frame, goalframe, removed goal, + INT last tp, last kp, last fp, last np); + +LET EXPRESSIONS = INT; + +LET EXPRESSION = STRUCT (TERM term, + FRAME index); + +TEXT VAR tcsymbol, tcarguments, tcarity, tcrest; INT VAR tp; + +TEXT VAR kcfirst, kcrest; INT VAR kp; + +ROW limit FRAMECELL VAR fc; INT VAR fp; + +ROW limit ENVIRONMENTCELL VAR nc; INT VAR np; + +ROW limit FRAMESTACK VAR fsc; INT VAR fsp; + +ROW limit EXPRESSION VAR ec; INT VAR ep; + +ROW limit CLAUSES VAR freec; INT VAR freep; + +SYMBOL VAR look ahead value; +TEXT VAR look ahead symbol, ahead symbol; +BOOL VAR look ahead empty, ahead empty; +INT VAR look ahead token, ahead symboltype; + +SYMBOL VAR pattern; + +TERMS VAR ts; + +TERM VAR t, t2, t3; + +CLAUSES VAR k, kl, knowledge base, candidates; + +FRAME VAR root, cut level, res frame; + +SYMBOLTABLE VAR symboltable, reset symboltable; + +FILE VAR file; + +BOOL VAR from file, tracing, testing, found, quoting, free of errors, finish; + +INT VAR i, j, reset tp, reset kp, reset freep, anonym value, + inference level, inference count, rule count; + +TEXT VAR command; + +REAL VAR start time:= 0.0; + +PROC init globals: + tp := nil; kp:= nil; + tracing:= FALSE; + testing:= FALSE; + symboltable:= empty thesaurus; + reset symboltable:= symboltable; + reset tp:= nil; + reset kp:= nil; + reset freep:= nil; + knowledge base:= nil; + from file:= FALSE; + inference count:= 0; + tcsymbol:=""; + tcarguments:=""; + tcarity:=""; + tcrest:=""; + kcfirst:=""; + kcrest:=""; + quoting:= TRUE +ENDPROC init globals; + +PROC init prooftree: + root := nil; + freep:= reset freep; + fp:= nil; fsp:= nil; np:= nil; ep:= nil; tp:= reset tp; kp:= reset kp; + symboltable:= reset symboltable; + free of errors:= TRUE; + candidates:= nil; + new (fp, root); + fc(root):= FRAMECELL:(t, nil, nil, nil, nil, nil, 0); + anonym value:= 0; + collect heap garbage; + finish:= FALSE +ENDPROC init proof tree; + +PROC prolog (TEXT CONST knowledge): + line; + last param (knowledge); + init globals; + bootstrap; + IF exists (knowledge) THEN consult (knowledge) FI; + IF free of errors + THEN prolog again + FI; + last param (knowledge). + + bootstrap: + TERMS VAR clauses:= nil; + init proof tree; + look ahead empty:= TRUE; ahead empty:= TRUE; + scan (boot); + WHILE look ahead <> end of input + REP read clause; + assertz (clauses); + clauses:= nil + PER; + reset tp:= tp; + reset kp:= kp; + reset symboltable:= symboltable. + + read clause: + TERM VAR term; + read term (term); + IF look ahead = period + THEN remove token + FI; + insert term in clauses. + + insert term in clauses: + TERMS VAR tmp; + new tp (tmp); + replace(tcsymbol,tmp,term.symbol); + replace(tcarguments,tmp,term.arguments); + replace(tcarity,tmp,term.arity); + replace(tcrest,tmp, clauses); + clauses:= tmp. + + remove token: + look ahead empty:= TRUE. + +ENDPROC prolog; + +BOOL PROC prolog (TEXT CONST query, TEXT VAR answer): + disable stop; + init prooftree; + read goals; + BOOL VAR result:= NOT prove; + answer is value of last variable; + result . + + read goals: + scan (query); + look ahead empty:= TRUE; ahead empty:= TRUE; + from file:= FALSE; + fc(root).subgoals:= nil; + read terms (fc(root).subgoals); + IF look ahead = period + THEN remove token + FI; + IF look ahead <> end of input + THEN syntax error ("unexpected characters after last goal") + FI. + + answer is value of last variable: + IF fc(root).environment <> nil + THEN + value (nc(fc(root).environment).first.variable, t, root); + file:= sequential file (output, "$$"); + sysout ("$$"); + write term backward (t); + sysout (""); + input (file); + getline (file, answer); + forget ("$$", quiet) + ELSE answer:= "" + FI . + + remove token: + look ahead empty:= TRUE. + +ENDPROC prolog; + +PROC prolog again: + disable stop; + lernsequenz auf taste legen ("q","bye"13""); + write (""13""10""5"?- "); + REP + init proof tree; + initiate read terms (fc(root).subgoals, "-"); + read goals; + prove goals; + UNTIL finish + PER; + lernsequenz auf taste legen ("q","break"13""). + + read goals: + IF is error + THEN c:= "?" + ELIF look ahead = open bracket + THEN remove token; + read consult list + ELSE read terms (fc(root).subgoals); + IF look ahead = period + THEN remove token + FI; + IF look ahead <> end of input + THEN syntax error ("unexpected characters after last goal") + FI + FI. + + prove goals: + IF tracing THEN inference level:= 0; line FI; + inference count:= 0; + start time:= clock (0); + REP + IF c <> "?" CAND prove + THEN IF tracing THEN line FI; + write (" no"13""10""5"?- "); + LEAVE prove goals + ELSE IF tracing THEN inference level:= 0 FI; + get cursor (i,j); IF i > 1 THEN line FI; + IF is error + THEN put error; clear error; putline (""4""{cleop}); + free of errors:= FALSE; + sysout (""); sysin (""); + putline ("type '?' to get explanations"); + putline ("type ';' to try next alternative"); + putline ("type any other key to stop") + ELSE write answers + FI; + get cursor (i, j); + write (""10""10""13""5"?- "); + getchar (c); + TEXT VAR c; + SELECT pos ("?;",c) OF + CASE 1: write ("?"); + inform + CASE 2: write (""13""5""3""3""); + get cursor (j, k); + cursor (i, k); + putline (";"); + OTHERWISE IF c >= " " COR c = ""27"" THEN push (c) FI; + LEAVE prove goals + END SELECT; + IF tracing THEN line FI; + IF is error + THEN put error; clear error; putline (""4""{cleop}) + FI + FI + PER. + + write answers: + write (" "); + IF fc(root).environment = nil + THEN IF free of errors THEN put ("yes") ELSE put ("no") FI + ELSE write environment list (root) + FI. + + remove token: + look ahead empty:= TRUE. + +ENDPROC prolog again; + +PROC prolog: prolog (last param) ENDPROC prolog; + +BOOL PROC prove: + enable stop; + initialize prove; + find potential candidates. + + handle remaining subgoals: + { all subgoals to the left are solved } + IF subgoals remain + THEN get candidates + ELSE LEAVE prove WITH FALSE + FI. + + find potential candidates: + REP try one candidate PER; TRUE. + + try one candidate: + { all candidates tried do not unify with the current goal } + IF head of one candidate unifies with the current goal + THEN push frame; + handle remaining subgoals + ELSE backtrack to the parent of the current goal + FI. + + backtrack to the parent of the current goal: + { none of the candidates unify with the current goal } + IF prooftree exhausted + THEN LEAVE prove WITH TRUE + ELSE pop frame + FI. + + prooftree exhausted: fsp = 1. + + initialize prove: + TERM VAR curr call; + FRAME VAR curr frame, top frame; + EXPRESSIONS VAR last ep; + IF fsp = nil + THEN curr frame:= root; + push frame; + handle remaining subgoals + ELSE IF tracing THEN line FI; + backtrack to the parent of the current goal + FI. + + head of one candidate unifies with the current goal: + son { curr frame is the resulting next son }. + + subgoals remain: + select frame {(curr frame, curr call)}. + + push frame: + fsp INCR 1; + fsc(fsp).frame:= curr frame; + fsc(fsp).goalframe:= nil; + fsc(fsp).last tp:= tp; + fsc(fsp).last kp:= kp; + fsc(fsp).last fp:= fp; + fsc(fsp).last np:= np. + + pop frame: + { fsp <> nil } + top frame:= fsc(fsp).frame; + curr frame:= fc(top frame).father; + reinsert current call as subgoal; + curr call:= fc(top frame).call; + candidates:= fc(top frame).rest; + cut level:= fc(top frame).level; + tp:= fsc(fsp).last tp; + kp:= fsc(fsp).last kp; + fp:= fsc(fsp).last fp; + np:= fsc(fsp).last np; + fsp DECR 1; + IF tracing CAND inference level > 0 CAND NOT testing + THEN write (""13""5""3""5""); inference level DECR 1 + FI; + undo bindings (fc(top frame).reset). + + reinsert current call as subgoal: + IF fsc(fsp).goalframe <> nil + THEN fc(fsc(fsp).goalframe).subgoals:= fsc(fsp).removed goal + FI. + + select frame: + REP + IF next call + THEN LEAVE select frame WITH TRUE + FI; + curr frame:= fc(curr frame).father + UNTIL curr frame = nil PER; + FALSE. + + next call: + ts:= fc(curr frame).subgoals; + IF ts = nil + THEN FALSE + ELSE remove subgoals; TRUE + FI. + + remove subgoals: + curr call:= TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts); + fc(curr frame).subgoals:= (tcrestISUB(ts)) ; + fsc(fsp).goalframe:= curr frame; + fsc(fsp).removed goal:= ts. + + get candidates: + initialize clauses; + WHILE more knowledge + REP find next clause candidate in knowledge base PER + { candidates = a list of clauses which may be unifiable with curr call } . + + initialize clauses: + fc(curr frame).level:= cut level; + cut level:= curr frame; + IF curr call.arity = var + THEN IF bound (curr call, curr frame, curr call, ts) THEN FI; + IF curr call.arity = var + THEN take goal itself as candidate; LEAVE get candidates + FI + FI; + k:= knowledge base; + found:= FALSE; + candidates:= nil. + + take goal itself as candidate: + new kp (candidates); + replace (kcfirst, candidates, goal itself); + replace (kcrest, candidates, nil). + + goal itself: + new tp (ts); + replace(tcsymbol,ts,curr call.symbol); + replace(tcarguments,ts, curr call.arguments); + replace(tcarity,ts, curr call.arity); + replace(tcrest,ts, nil); + ts. + + find next clause candidate in knowledge base: + IF (tcsymbolISUB((kcfirstISUB(k)) )) = curr call.symbol + THEN found:= TRUE; + IF (tcarityISUB((kcfirstISUB(k)) )) = curr call.arity + THEN insert clause in candidates + FI + ELIF found + THEN LEAVE get candidates + FI; + k:= (kcrestISUB(k)) . + + more knowledge: k <> nil. + + insert clause in candidates: + kl:= candidates; + new kp (candidates); + replace(kcfirst,candidates,kcfirstISUBk); + replace(kcrest, candidates, kl). + + son: + { If rules has n sons, then this refinement will return TRUE the first + n times, it is called and FALSE forever after. + IF son then curr frame has become a frame for the next son. + So this refinement helps to construct the prooftree. + } + + IF candidates = nil + THEN FALSE + ELSE create next son + FI. + + create next son: + initialize son; + REP try to unify curr call with candidates + UNTIL candidates exhausted PER; + { not unified } + forget son. + + initialize son: + last ep:= ep; + new (fp, res frame); + fc(res frame).environment:= nil. + + try to unify curr call with candidates: + k:= (kcfirstISUB(candidates)) ; + IF + unify (curr call, + curr frame, + TERM:(tcsymbolISUBk, tcargumentsISUBk, tcarityISUBk), + res frame) + THEN + IF tracing THEN trace unification results FI; + apply rule; + fill result frame + ELSE remove curr call from candidates + FI. + + candidates exhausted: candidates = nil. + + forget son: + fp DECR 1; FALSE. + + fill result frame: + ts:= (kcfirstISUB(candidates)) ; + fc(res frame):= FRAMECELL:(curr call, + curr frame, + tcrestISUBts, + fc(res frame).environment, + last ep, + (kcrestISUB(candidates)) , + cut level); + curr frame:= res frame; + LEAVE son WITH TRUE. + + remove curr call from candidates: + candidates:= (kcrestISUB(candidates)) ; + LEAVE try to unify curr call with candidates. + + apply rule: + SELECT curr call.symbol OF + CASE cons: {cons, to construct lists, see PROC unify} + CASE cut: fc(res frame):= FRAMECELL:(curr call, curr frame, nil, + fc(res frame).environment, last ep, nil, cut level); + curr frame:= res frame; + FOR ts FROM fp DOWNTO cut level + REP fc(ts).rest:= nil PER; + LEAVE son WITH TRUE + CASE bye: IF curr call.arity = 0 + THEN push (""13""); + finish:= TRUE + FI + CASE list: IF curr call.arity = 0 COR curr call.arity = 1 + THEN found:= TRUE; + IF curr call.arity = 0 + THEN pattern:= cut + ELSE value (argfirst, t, curr frame); + pattern:= t.symbol + FI; + write knowledgebase (knowledge base) + FI + CASE call: undo bindings (last ep); + new tp (ts); + replace(tcrest,ts, fc(curr frame).subgoals); + fc(curr frame).subgoals:= ts; + value (argfirst, t, curr frame); + t.arguments:= revers (t.arguments); + replace(tcsymbol,ts, t.symbol); + replace(tcarguments,ts, t.arguments); + replace(tcarity,ts, t.arity); + LEAVE son WITH TRUE + CASE xpar: {X parameter of call} + CASE writ: IF curr call.arity = 1 + THEN value (argfirst, t, curr frame); + quoting:= FALSE; + write term backward (t); write (" "); + quoting:= TRUE + FI + CASE wriq: IF curr call.arity = 1 + THEN value (argfirst, t, curr frame); + write term backward (t); write (" ") + FI + CASE read: IF curr call.arity <> 1 + THEN + ELIF argfirst.arity = var + THEN initiate read terms (ts, + name (symboltable,argfirst.symbol)); + read term (t); + nc(fc(curr frame).environment).first.substitute:= t + ELSE syntax error ("read parameter must be variable") + FI + CASE get0, get: + IF curr call.arity <> 1 + THEN + ELIF argfirst.arity = var + THEN getchar (command); + WHILE curr call.symbol = get + CAND code(command) < 32 + REP getchar (command) PER; + t.arity:= integer; + t.arguments:= nil; + t.symbol:= code (command); + nc(fc(curr frame).environment).first.substitute:= t + ELSE syntax error ("get parameter must be variable") + FI + CASE put0: value (argfirst, t, curr frame); + IF curr call.arity = 1 CAND t.arity = integer + THEN write (code (t.symbol)) + FI + CASE incr: IF curr call.arity = 1 + THEN + value(argfirst, t, curr frame); + t.symbol INCR 1; + IF t.arity = integer + CAND argfirst.arity = var + THEN k:= fc(curr frame).environment; + nc(k).first.substitute:= t; + ELSE syntax error ("integer variable expected") + FI FI + CASE ass: IF curr call.arity = 1 + THEN value (argfirst,t,currframe); + IF t.symbol = nil + CAND t.arguments > nil + THEN assertz (t.arguments); + IF free of errors + THEN reset tp:= tp; + reset kp:= kp; + reset symboltable:= symboltable + FI + ELSE syntax error ("parameter must be a list") + FI FI + CASE assa: IF curr call.arity = 1 + THEN value (argfirst,t,currframe); + IF t.symbol = nil + CAND t.arguments > nil + THEN asserta (t.arguments); + IF free of errors + THEN reset tp:= tp; + reset kp:= kp; + reset symboltable:= symboltable + FI + ELSE syntax error ("parameter must be a list") + FI FI + CASE retr: IF curr call.arity = 1 + THEN value (argfirst,t,currframe); + IF t.symbol = nil + CAND t.arguments > nil + THEN i:= rule count; + retract (t.arguments); + IF i <> rule count + THEN remove curr call from candidates + FI + ELSE syntax error ("parameter must be a list") + FI FI + CASE vari: IF curr call.arity = 1 + THEN value (argfirst, t, curr frame); + IF t.arity <> var + THEN remove curr call from candidates + FI + FI + CASE is: IF curr call.arity = 2 + THEN disable stop; + t.symbol:= arith (TERM:(tcsymbolISUBargrest, + tcargumentsISUBargrest, + tcarityISUBargrest), + curr frame); + IF is error THEN put error; clear error FI; + enable stop; + t.arity := integer; + t.arguments:= nil; + IF unify (argfirst, curr frame, t, curr frame) + THEN LEAVE apply rule + FI FI; + remove curr call from candidates + CASE ypar: {Y parameter of is} + CASE dif: IF curr call.arity = 2 CAND + unify (argfirst, + curr frame, + TERM:(tcsymbolISUBargrest, + tcargumentsISUBargrest, + tcarityISUBargrest), + curr frame) + THEN remove curr call from candidates + FI + CASE leq: IF curr call.arity = 2 + THEN get operands; + IF t.arity = integer + THEN IF t.symbol <= t2.symbol + THEN LEAVE apply rule + FI + ELIF name (symboltable, t.symbol) <= + name (symboltable, t2.symbol) + THEN LEAVE apply rule + FI FI; + remove curr call from candidates + CASE eq: IF curr call.arity = 2 + THEN get operands; + IF NOT ( t = t2 ) + THEN remove curr call from candidates + FI FI + CASE univ: IF curr call.arity = 2 + CAND np > fsc(fsp).last np + THEN + get operands; + IF t2.arity = var CAND t.arity >= 0 + THEN new tp (ts); + replace (tcsymbol,ts,t.symbol); + replace (tcarguments, ts, nil); + replace (tcarity,ts,0); + replace (tcrest,ts,revers(t.arguments)); + nc(np).first.substitute.arguments:= ts; + nc(np).first.substitute.symbol:= nil; + nc(np).first.substitute.arity:= t.arity + 1 + ELIF t.arity = var CAND t2.arity > 0 + CAND t2.symbol <= cons + THEN np DECR 1; + t2. arguments:= revers(t2.arguments); + nc(np).first.substitute.symbol:= + tcsymbol ISUB t2.arguments; + nc(np).first.substitute.arguments:= + tcrest ISUB t2.arguments; + nc(np).first.substitute.arity:= t2.arity - 1; + np INCR 1 + ELSE syntax error ("wrong parameter after =..") + FI FI + CASE clau: get operands; + IF curr call.arity = 2 + THEN + IF t.arity < 0 + THEN syntax error ("clause with wrong parameter") + ELSE find clause; + k:= tcrest ISUB (kcfirstISUBk); + t3.symbol:= nil; + t3.arguments:= k; + t3.arity:= no of terms (k); + IF NOT unify (t2, res frame, + t3, curr frame) + THEN remove curr call from candidates + FI + FI + FI + CASE claupar: { anonymous parameter of clause } + CASE nam: IF curr call.arity = 2 + THEN get operands; + IF t.arity = var + CAND t2.symbol = nil + THEN command:= ""; + k:= t2.arguments; + REP command:= code (tcsymbolISUBk) + command; + k:= tcrestISUBk + UNTIL k <= nil PER; + t.symbol:= link (symboltable, command); + IF t.symbol = 0 + THEN insert (symboltable, command, t.symbol); + FI; + t.arity:= 0; + t.arguments:= nil; + nc(fc(curr frame).environment).first.substitute:= t + ELIF t2.arity = var + CAND t.arity = 0 + THEN command:= name (symboltable, t.symbol); + ts:= nil; + FOR k FROM 1 UPTO length(command) + REP new tp (i); + IF ts = nil + THEN ts:= i + ELSE replace (tcrest, j, i) + FI; + j:= i; + replace (tcrest, i, nil); + replace (tcarity, i, integer); + replace (tcarguments, i, nil); + replace (tcsymbol, i, code (command SUB k)) + PER; + t3.arity:= length(command); + t3.arguments:= ts; + t3.symbol:= nil; + IF unify (t2, res frame, t3, curr frame) THEN FI + ELSE syntax error ("name insufficient parameters") + FI FI + CASE argi: get operands; + IF curr call.arity = 3 + THEN k:= argrest; + value (TERM:(tcsymbolISUB(tcrestISUB(k)), + tcargumentsISUB(tcrestISUB(k)), + tcarityISUB(tcrestISUB(k))), + t3, + curr frame); + IF t.arity <> integer COR t2.arity <= 0 + COR t.symbol <= 0 COR t.symbol > t2.arity + THEN syntax error ("arg with wrong parameter") + ELSE + FOR k FROM t2.arity DOWNTO ( t.symbol + 1) + REP IF t2.arguments <= nil + THEN syntax error ("out of range"); + LEAVE apply rule + FI; + t2.arguments:= tcrestISUB(t2.arguments) + PER; + IF t3.arity = var + THEN nc(fc(curr frame).environment).first.substitute + := TERM:(tcsymbolISUBt2.arguments, + tcargumentsISUBt2.arguments, + tcarityISUBt2.arguments) + ELIF NOT unify (TERM:(tcsymbolISUBt2.arguments, + tcargumentsISUBt2.arguments, + tcarityISUBt2.arguments), + curr frame, + t3, + curr frame) + THEN remove curr call from candidates + FI + FI + FI + CASE zpar: {z parameter of arg} + CASE func: IF curr call.arity = 3 + THEN + get operands; + k:= argrest; + value (TERM:(tcsymbolISUB(tcrestISUB(k)), + tcargumentsISUB(tcrestISUB(k)), + tcarityISUB(tcrestISUB(k))), + t3, + curr frame); + IF t2.arity = var + THEN IF t3.arity = var + THEN + t2.symbol:= argfirst.symbol; + t2.arity := 0; + nc(nc(fc(curr frame).environment).rest).first. + substitute:= t2; + k:= tcrestISUB(k); + t3.symbol:= argfirst.arity; + t3.arity := integer; + nc(fc(curr frame).environment).first. + substitute:= t3 + ELIF t3.arity = integer + CAND t.arity = t3.symbol + THEN t.arity:= 0; + t.arguments:= nil; + nc(fc(curr frame).environment).first. + substitute:= t + ELSE remove curr call from candidates + FI + ELIF ( t.arity = var) + CAND (t2.arity = 0) + CAND (t3.arity = integer) + THEN t2.arity:= t3.symbol; + FOR k FROM 1 UPTO t3.symbol + REP new tp (ts); + replace (tcarity, ts, var); + anonym value DECR 1; + replace (tcsymbol, ts, anonym value); + replace (tcarguments, ts, nil); + replace (tcrest, ts, t2.arguments); + t2.arguments:= ts + PER; + nc(fc(curr frame).environment).first. + substitute:= t2 + ELIF t2.arity <= 0 + THEN IF t.symbol = t2.symbol + THEN IF t.arity = t3.symbol + CAND t3.arity = integer + THEN + ELIF t3.arity = var + THEN t3.arity := integer; + t3.symbol:= t.arity; + nc(fc(curr frame).environment).first. + substitute:= t3 + ELSE remove curr call from candidates + FI + ELSE remove curr call from candidates + FI + ELSE syntax error ("wrong functor parameters") + FI FI + CASE elan: disable stop; + lernsequenz auf taste legen ("q","break"13""); + SELECT + pos("consult,reconsult,sysout,sysin,forget,trace,line,abolish," + ,name (symboltable, argfirst.symbol) + ",") OF + CASE 01: consult (arg1) + CASE 09: reconsult (arg1) + CASE 19: sysout (arg1) + CASE 26: sysin (arg1) + CASE 32: forget (arg1, quiet) + CASE 39: trace (arg1) + CASE 45: line + CASE 50: value (TERM:(tcsymbolISUBargrest, + tcargumentsISUBargrest, + tcarityISUBargrest), + t, + curr frame); + abolish (t.symbol) + OTHERWISE do (elan command) + ENDSELECT; + lernsequenz auf taste legen ("q","bye"13""); + IF is error THEN put error; clear error FI; + enable stop + END SELECT. + + get operands: + value (argfirst, t, curr frame); + value (TERM:(tcsymbolISUBargrest, + tcargumentsISUBargrest, + tcarityISUBargrest), + t2, + curr frame). + + argfirst:TERM:(tcsymbolISUBcurr call.arguments, + tcargumentsISUBcurr call.arguments, + tcarityISUBcurr call.arguments). + + argrest: tcrestISUBcurr call.arguments. + + arg1: value (TERM:(tcsymbolISUBargrest, + tcargumentsISUBargrest, + tcarityISUBargrest), + t, + curr frame); + name(symboltable, t.symbol). + +find clause: + k:= knowledgebase; + WHILE k <> nil + REP + ts:= kcfirstISUBk; + IF TERM:(tcsymbolISUBts,tcargumentsISUBts,tcarityISUBts) = t + THEN LEAVE find clause + FI; + k:= kcrestISUBk + PER; + remove curr call from candidates; + LEAVE apply rule. + + elan command: + command:= ""; + ts:= curr call.arguments; + WHILE ts <> nil + REP value (TERM:(tcsymbolISUBts, + tcargumentsISUBts, + tcarityISUBts), + t, + curr frame); + command CAT name (symboltable, t.symbol); + found:= ts = curr call.arguments; + ts:= tcrestISUB(ts); + IF found + THEN IF ts > nil THEN command CAT "(""" FI + ELIF ts = nil + THEN command CAT """)" + ELSE command CAT """,""" + FI + PER; + command. + + trace unification results: + inference level INCR 1; + write term (curr call); write ("="); + value (TERM:(tcsymbolISUB(kcfirstISUB(candidates)) , + tcargumentsISUB(kcfirstISUB(candidates)) , + tcarityISUB(kcfirstISUB(candidates)) ), t, res frame); + write term backward (t); + IF testing + THEN ts:= ep; + IF ts > last ep THEN write (" with ") FI; + list expressions + FI; + line. + + list expressions: + WHILE ts > last ep + REP k:= fc(ec(ts).index).environment; + WHILE nc(k).first.variable.symbol <> ec(ts).term.symbol + REP k:= nc(k).rest PER; + write term (ec(ts).term); write ("="); + write term (nc(k).first.substitute); write (" "); + ts DECR 1 + PER. + +ENDPROC prove; + +BOOL PROC unify (TERM CONST t1, FRAME CONST f1, + TERM CONST t2, FRAME CONST f2): + + { Unifies the expressions <t1,f1^.environment> and <t2,f2^.environment>, + If unification succeeds, both environments are updated. } + +{}{inference count INCR 1;} + IF f1 = f2 CAND t1 = t2 + THEN TRUE + ELIF t1.arity = var + THEN TERM VAR t; + FRAME VAR f; + IF bound (t1, f1, t, f) + THEN unify (t, f, t2, f2) + { ELIF occurs (t1, f1, t2, f2) THEN FALSE } + ELSE bind expression 1; + push expression 1; + TRUE + FI + ELIF t2.arity = var + THEN IF bound (t2, f2, t, f) + THEN unify (t, f, t1, f1) + { ELIF occurs (t2, f2, t1, f1) THEN FALSE } + ELSE bind expression 2; + push expression 2; + TRUE + FI + ELIF t1.symbol = t2.symbol + CAND t1.arity = t2.arity + THEN constant or compound term + ELIF t1.symbol = cons CAND t2.symbol = nil + CAND t1.arity = 2 CAND t2.arguments > nil + CAND unify (TERM:(tcsymbolISUBt1.arguments, + tcargumentsISUBt1.arguments, + tcarityISUBt1.arguments), + f1, + TERM:(tcsymbolISUBt2.arguments, + tcargumentsISUBt2.arguments, + tcarityISUBt2.arguments), + f2) + THEN construct list 1 + ELIF t2.symbol = cons CAND t1.symbol = nil + CAND t2.arity = 2 CAND t1.arguments > nil + CAND unify (TERM:(tcsymbolISUBt2.arguments, + tcargumentsISUBt2.arguments, + tcarityISUBt2.arguments), + f2, + TERM:(tcsymbolISUBt1.arguments, + tcargumentsISUBt1.arguments, + tcarityISUBt1.arguments), + f1) + THEN construct list 2 + ELSE FALSE + FI. + +constant or compound term: + { arguments of t1 and t2 are properly instantiated by the parser } + EXPRESSIONS VAR last ep:= ep; + TERMS VAR x:= t1.arguments, y:= t2.arguments; + WHILE x <> nil + REP IF unify (TERM:(tcsymbolISUBx, tcargumentsISUBx, tcarityISUBx), + f1, + TERM:(tcsymbolISUBy, tcargumentsISUBy, tcarityISUBy), + f2) + THEN x:= tcrestISUB(x); + y:= tcrestISUB(y) + ELSE undo bindings (last ep); + LEAVE unify WITH FALSE + FI + PER; + TRUE. + + construct list 1: + last ep:= ep; + IF t2.symbol = cons + THEN TERM VAR tail:= TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)), + tcargumentsISUB(tcrestISUB(t2.arguments)), + tcarityISUB(tcrestISUB(t2.arguments))); + ELSE tail:= TERM: (nil, (tcrestISUB(t2.arguments)) , + no of terms (t2.arguments) - 1); + FI; + IF bound (TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , + tcargumentsISUB(tcrestISUB(t1.arguments)) , + tcarityISUB(tcrestISUB(t1.arguments)) ), + f1, + t, + f) + THEN IF unify (t, f, tail, f2) + THEN TRUE + ELSE undo bindings (last ep); FALSE + FI + ELSE bind tail 1; + push tail 1; + TRUE + FI. + + construct list 2: + last ep:= ep; + IF t1.symbol = cons + THEN tail:= TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , + tcargumentsISUB(tcrestISUB(t1.arguments)) , + tcarityISUB(tcrestISUB(t1.arguments)) ); + ELSE tail:= TERM: (nil, tcrestISUB(t1.arguments), + no of terms (t1.arguments) - 1); + FI; + IF bound (TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , + tcargumentsISUB(tcrestISUB(t2.arguments)) , + tcarityISUB(tcrestISUB(t2.arguments)) ), + f2, + t, + f) + THEN IF unify (t, f, tail, f1) + THEN TRUE + ELSE undo bindings (last ep); FALSE + FI + ELSE bind tail 2; + push tail 2; + TRUE + FI. + + bind expression 1: + { bind the expression <t1, f1> to <t2, f2> in the environment <f1> } + new environment n; + nc(n).first:= SUBSTITUTION:(t1, t2, f2); + nc(n).rest :=fc(f1).environment; + fc(f1).environment:= n. + + bind expression 2: + new environment n; + nc(n).first:= SUBSTITUTION:(t2, t1, f1); + nc(n).rest :=fc(f2).environment; + fc(f2).environment:= n. + + bind tail 1: + new environment n; + nc(n).first:= SUBSTITUTION:( + TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)), + tcargumentsISUB(tcrestISUB(t1.arguments)) , + tcarityISUB(tcrestISUB(t1.arguments)) ), + tail, + f2); + nc(n).rest :=fc(f1).environment; + fc(f1).environment:= n. + + bind tail 2: + new environment n; + nc(n).first:= SUBSTITUTION:( + TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , + tcargumentsISUB(tcrestISUB(t2.arguments)) , + tcarityISUB(tcrestISUB(t2.arguments)) ), + tail, + f1); + nc(n).rest :=fc(f2).environment; + fc(f2).environment:= n. + + push expression 1: + ep INCR 1; + ec(ep):= EXPRESSION:(t1, f1). + + push expression 2: + ep INCR 1; + ec(ep):= EXPRESSION:(t2, f2). + + push tail 1: + ep INCR 1; + ec(ep):= EXPRESSION:(TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , + tcargumentsISUB(tcrestISUB(t1.arguments)) , + tcarityISUB(tcrestISUB(t1.arguments)) ), + f1). + + push tail 2: + ep INCR 1; + ec(ep):= EXPRESSION:(TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , + tcargumentsISUB(tcrestISUB(t2.arguments)) , + tcarityISUB(tcrestISUB(t2.arguments)) ), + f2). + + new environment n: + ENVIRONMENT VAR n; + IF np = limit THEN pegeloverflow ELSE np INCR 1; n:= np FI +ENDPROC unify; + +BOOL OP = (TERM CONST t1, t2): { INLINE; } + { Two terms are equal iff their printed representations are + indistinguishable. Don't confuse with equal expressions. } + + IF ( t1.symbol = t2.symbol ) + CAND ( t1.arity = t2.arity ) + THEN IF t1.arguments = 0 + THEN terms are variables or constants + ELSE terms are compound + FI + ELSE FALSE + FI. + + terms are variables or constants: TRUE. + + terms are compound: + TERMS VAR x:= t1.arguments, + y:= t2.arguments; + WHILE x <> nil + REP IF recursive equal (TERM:(tcsymbolISUBx, + tcargumentsISUBx, + tcarityISUBx), + TERM:(tcsymbolISUBy, + tcargumentsISUBy, + tcarityISUBy)) + THEN x:= tcrestISUB(x); + y:= tcrestISUB(y) + ELSE LEAVE = WITH FALSE + FI + PER; TRUE. +ENDOP =; + +BOOL PROC recursive equal (TERM CONST t1, t2): t1=t2 +ENDPROC recursive equal; + +PROC undo bindings (EXPRESSIONS CONST last ep): + { Remove the binding for each of the expressions } + WHILE ep > last ep + REP remove matching substitutions; + remove expression + PER. + + remove matching substitutions: + { with variable equal to term t from environment env } + TERM VAR t:= ec(ep).term; + ENVIRONMENT VAR n:= env, last:= nil; + WHILE n <> nil + REP IF nc(n).first.variable.symbol = t.symbol + THEN forget n + ELSE last:= n + FI; + n:= nc(n).rest + PER. + + forget n: + IF last = nil + THEN env := nc(n).rest + ELSE nc(last).rest:= nc(n).rest + FI; + IF n = np THEN np DECR 1 FI. + + env: fc(ec(ep).index).environment. + + remove expression: + { Removes the first expression from e recovering the space used } + ep DECR 1. + +END PROC undo bindings; + +PROC consult (TEXT CONST knowledge): + { asserts the clauses from the file into knowledge base } +{} enable stop; + IF NOT exists (knowledge) + THEN syntax error ("consulting file not existing"); LEAVE consult + FI; + last param (knowledge); + TERMS VAR clauses; + BOOL VAR single:= TRUE; + rule count:= 0; + initiate read terms (knowledge, clauses); + WHILE look ahead <> end of input + REP rule count INCR 1; + cout (rule count); + read clause; + assertz (clauses); + clauses:= nil + PER; + remove token; + IF anything noted + THEN modify (file); + note edit (file) + FI; + IF free of errors + THEN reset tp:= tp; + reset kp:= kp; + reset symboltable:= symboltable; + put (rule count) + ELSE put (0); from file:= FALSE + FI; + putline ("rules inserted."); + line . + + read clause: + TERM VAR term; + IF single + THEN read term (term); + IF term.arity = var + THEN syntax error ("clause starts with variable") + ELIF name (symboltable, term.symbol) = ":-" + THEN read terms (clauses); + call terms (clauses); + LEAVE consult + FI; + IF look ahead = colon + THEN remove token; + read terms (clauses) + FI + ELIF look ahead = semicolon + THEN remove token; + read terms (clauses) + FI; + IF look ahead = semicolon + THEN single:= FALSE + ELIF look ahead = period + THEN single:= TRUE; + remove token + ELSE syntax error ("period or semicolon expected") + FI; + insert term in clauses. + + insert term in clauses: + TERMS VAR tmp; + new tp (tmp); + replace(tcsymbol,tmp,term.symbol); + replace(tcarguments,tmp,term.arguments); + replace(tcarity,tmp,term.arity); + replace(tcrest,tmp, clauses); + clauses:= tmp. + + remove token: + look ahead empty:= TRUE. + +END PROC consult; + +PROC reconsult (TEXT CONST knowledge): + { asserts the clauses from the file into knowledge base } +{} enable stop; + IF NOT exists (knowledge) + THEN syntax error ("reconsulting file not existing"); LEAVE reconsult + FI; + last param (knowledge); + TERMS VAR clauses; + BOOL VAR single:= TRUE; + rule count:= 0; + initiate read terms (knowledge, clauses); + WHILE look ahead <> end of input + REP rule count INCR 1; + cout (rule count); + read clause; + abolish (tcsymbol ISUB clauses); + clauses:= nil + PER; + remove token; + consult (knowledge). + + read clause: + TERM VAR term; + IF single + THEN read term (term); + IF term.arity = var + THEN syntax error ("clause starts with variable") + ELIF name (symboltable, term.symbol) = ":-" + THEN read terms (clauses); + call terms (clauses); + LEAVE reconsult + FI; + IF look ahead = colon + THEN remove token; + read terms (clauses) + FI + ELIF look ahead = semicolon + THEN remove token; + read terms (clauses) + FI; + IF look ahead = semicolon + THEN single:= FALSE + ELIF look ahead = period + THEN single:= TRUE; + remove token + ELSE syntax error ("period or semicolon expected") + FI; + insert term in clauses. + + insert term in clauses: + TERMS VAR tmp; + new tp (tmp); + replace(tcsymbol,tmp,term.symbol); + replace(tcarguments,tmp,term.arguments); + replace(tcarity,tmp,term.arity); + replace(tcrest,tmp, clauses); + clauses:= tmp. + + remove token: + look ahead empty:= TRUE. + +END PROC reconsult; + +PROC assertz (TERMS CONST clause): + { Inserts the clause into the knowledge base before the first clause + beginning with the same functor. + Clauses beginning with the same functor are assumed to be listed + consecutively. + } + CLAUSES VAR c1, c2, c3; + IF free of errors + THEN IF freep > nil + THEN c3:= freec(freep); + freep DECR 1; + IF reset freep > freep THEN reset freep:= freep FI + ELSE new kp (c3) + FI; + replace(kcfirst,c3, clause); + IF knowledge base = nil + COR (tcsymbolISUB((kcfirstISUB(knowledgebase)) )) = + (tcsymbolISUB(clause)) + THEN insert on top + ELSE c1:= knowledge base; + REP find and insert clause PER + FI + FI. + + find and insert clause: + c2:= (kcrestISUB(c1)) ; + IF c2 = nil + THEN insert on top + ELIF (tcsymbolISUB((kcfirstISUB(c2)) )) = (tcsymbolISUB(clause)) + THEN insert before + FI; + c1:= c2. + + insert on top: + replace(kcrest,c3, knowledge base); + knowledge base:= c3; + LEAVE assertz. + + insert before: + replace(kcrest,c3, c2); + replace(kcrest,c1, c3); + LEAVE assertz. + +ENDPROC assertz; + +PROC asserta (TERMS CONST clause): + { Inserts the clause into the knowledge base after the last clause + beginning with the same functor. + Clauses beginning with the same functor are assumed to be listed + consecutively. + } + CLAUSES VAR c1, c2, c3; + IF free of errors + THEN IF freep > nil + THEN c3:= freec(freep); + freep DECR 1; + IF reset freep > freep THEN reset freep:= freep FI + ELSE new kp (c3) + FI; + replace(kcfirst,c3, clause); + IF knowledge base = nil + THEN replace(kcrest,c3, knowledge base); + knowledge base:= c3 + ELSE c1:= knowledge base; + REP find and insert clause PER + FI + FI. + + find and insert clause: + c2:= (kcrestISUB(c1)) ; + IF c2 = nil + THEN append after c1 + ELIF (tcsymbolISUB((kcfirstISUB(c2)) )) = (tcsymbolISUB(clause)) + THEN insert behind + FI; + c1:= c2. + + append after c1: + replace(kcrest,c1, clause); + LEAVE asserta. + + insert behind: + REP c1:= c2; + c2:= (kcrestISUB(c1)) ; + UNTIL (tcsymbolISUB((kcfirstISUB(c2)) )) <> (tcsymbolISUB(clause)) + PER; + replace(kcrest,c3, c2); + replace(kcrest,c1, c3); + LEAVE asserta. + +ENDPROC asserta; + +PROC retract (TERMS CONST clause): + { Retracts the clause from the knowledge base. } + CLAUSES VAR c1:= knowledge base, c2; + IF free of errors + THEN IF c1 = nil + THEN rule count DECR 1 + ELIF c1 > build ins CAND terms eq ((kcfirstISUB(c1)) , clause) + THEN retract top + ELSE REP find and retract clause PER + FI + FI. + + find and retract clause: + c2:= (kcrestISUB(c1)) ; + IF c2 = nil + THEN rule count DECR 1; + LEAVE retract + ELIF c2 > build ins CAND terms eq ((kcfirstISUB(c2)) , clause) + THEN retract c2 + FI; + c1:= c2. + + retract top: + freep INCR 1; + reset freep:= freep; + freec(freep):= knowledge base; + knowledge base:= (kcrestISUB(knowledge base)) ; + LEAVE retract. + + retract c2: + replace(kcrest,c1, (kcrestISUB(c2)) ); + freep INCR 1; + reset freep:= freep; + freec(freep):= c2; + LEAVE retract. + +ENDPROC retract; + +PROC abolish (SYMBOL CONST clause): + { Retracts all the clauses with this name from the knowledge base. } +{} enable stop; + CLAUSES VAR c1:= knowledge base, c2; + IF free of errors + THEN REP + IF c1 = nil + THEN rule count DECR 1; + LEAVE abolish + ELIF c1 = knowledgebase CAND c1 > build ins + CAND (tcsymbol ISUB(kcfirstISUBc1)) = clause + THEN retract top; + c1:= knowledgebase + ELSE find and retract clause + FI + PER + FI. + + find and retract clause: + c2:= kcrestISUBc1 ; + IF c2 = nil + THEN rule count DECR 1; + LEAVE abolish + ELIF c2 > build ins + CAND (tcsymbol ISUB(kcfirstISUBc2)) = clause + THEN retract c2 + ELSE c1:= c2 + FI. + + retract top: + freep INCR 1; + reset freep:= freep; + freec(freep):= knowledge base; + knowledge base:= (kcrestISUB(knowledge base)). + + retract c2: + replace(kcrest,c1, (kcrestISUB(c2)) ); + freep INCR 1; + reset freep:= freep; + freec(freep):= c2. + +ENDPROC abolish; + +BOOL PROC terms eq (TERMS CONST a, b): + IF a = b + THEN TRUE + ELIF a = 0 COR b = 0 + THEN FALSE + ELIF TERM:(tcsymbolISUBa, + tcargumentsISUBa, + tcarityISUBa) = + TERM:(tcsymbolISUBb, + tcargumentsISUBb, + tcarityISUBb) + THEN terms eq ((tcrestISUB(a)) , (tcrestISUB(b)) ) + ELSE FALSE + FI +ENDPROC terms eq; + +PROC value (TERM CONST t, TERM VAR r, FRAME CONST f): + { sets r to the value of t in f^.environment } +{} enable stop; + IF t.arguments = 0 + THEN IF t.arity = var + THEN variable term + ELSE constant term + FI + ELSE compound term + FI. + + constant term: r:= t. + + variable term: + TERM VAR t1, t2; + FRAME VAR f1; + IF bound (t, f, t1, f1) + THEN value (t1, r, f1) + ELSE r:= t + FI. + + compound term: + INT VAR step:= 3; + TERMS VAR ts:= t.arguments; + r.arguments:= nil; + WHILE ts <> nil + REP value (TERM:(tcsymbolISUBts, + tcargumentsISUBts, + tcarityISUBts), + t1, + f); + IF stepping + CAND step = 1 CAND t.symbol = cons CAND t1.symbol = nil + THEN step:= 0; + value (t1, t2, f); + ts:= t2.arguments + ELSE ts:= tcrestISUB(ts); + push term in arguments + FI; + PER; + IF step = 0 + THEN r.symbol:= nil + ELSE r.symbol:= t.symbol + FI; + r.arity:= no of terms (r.arguments). + + stepping: + IF step > 1 THEN step DECR 1; TRUE ELSE FALSE FI. + + push term in arguments: + TERMS VAR term; + new tp (term); + replace(tcsymbol,term, t1.symbol); + replace(tcarguments,term, t1.arguments); + replace(tcarity,term, t1.arity); + replace(tcrest,term, r.arguments); + r.arguments:= term. +ENDPROC value; + +BOOL PROC bound (TERM CONST t1, FRAME CONST f1, + TERM VAR t2, FRAME VAR f2): + { returns TRUE iff the expression <t1, f1^.environment> is bound and + assigns <t2, f2^.environment> the expression to which it is bound. } + ENVIRONMENT VAR n:= fc(f1).environment; + SUBSTITUTION VAR sub; + WHILE n <> nil + REP sub:= nc(n).first; + IF t1.symbol = sub.variable.symbol + THEN t2:= sub.substitute; + f2:= sub.others; + LEAVE bound WITH TRUE + ELSE n:= nc(n).rest + FI + PER; + FALSE +ENDPROC bound; + +PROC append term (TERM CONST appendix, TERMS VAR list): + TERMS VAR term, last term; + IF list = nil + THEN new tp (term); + list:= term + ELSE term:= list; + REP last term:= term; + term:= tcrestISUB(term) + UNTILterm = nil PER; + new tp (term); + replace(tcrest,last term, term); + FI; + replace(tcsymbol,term,appendix.symbol); + replace(tcarguments,term,appendix.arguments); + replace(tcarity,term,appendix.arity); + replace(tcrest,term, nil) +END PROC append term; + +TERMS PROC revers (TERMS CONST ts): + IF ts <= nil + THEN ts + ELSE TERMS VAR reverted:= revers ((tcrestISUB(ts)) ); + append term (TERM:(tcsymbolISUBts, + revers (tcargumentsISUBts), + tcarityISUBts), + reverted); + reverted + FI +ENDPROC revers; + +PROC call terms (TERMS VAR ts): + TEXT VAR old:= sysout; + forget ("$sysin$",quiet); + sysout ("$sysin$"); + WHILE ts > nil + REP write term (TERM:(tcsymbolISUBts, + tcargumentsISUBts, + tcarityISUBts)); + line; + ts:= tcrestISUB(ts) + PER; + write ("elan(sysin,())."); + sysout (old); + sysin ("$sysin$") +ENDPROC call terms; + +PROC write environment list (FRAME CONST frame): + write environment list (frame, fc(frame).environment); +ENDPROC write environment list; + +PROC write environment list (FRAME CONST frame, ENVIRONMENT CONST en): + IF en <> nil + THEN write environment list (frame, nc(en).rest); + write term (nc(en).first.variable); write (" = "); + value (nc(en).first.variable, t, frame); + write term backward (t); + IF en <> fc(frame).environment THEN write (", ") FI + FI +ENDPROC write environment list; + +PROC write knowledge base (CLAUSES CONST k): + TERMS VAR t:= (kcfirstISUB(k)) ; + IF t > nil CAND k <= reset kp CAND k > build ins + CAND (pattern = cut COR pattern = (tcsymbolISUB(t)) + ) + THEN found:= FALSE; + IF (kcrestISUB(k)) > nil + THEN write knowledge base ((kcrestISUB(k)) ) + FI; + write term (TERM:(tcsymbolISUBt, tcargumentsISUBt, tcarityISUBt)); + t:= (tcrestISUB(t)) ; + IF t > nil + THEN write (":- "); + write terms + FI; + write ("."); + line + ELIF (found COR k <= build ins) CAND (kcrestISUB(k)) > nil + THEN write knowledge base ((kcrestISUB(k)) ) + FI. + + write terms: + BOOL VAR once:= FALSE; + WHILE t <> nil + REP IF once THEN write (", ") ELSE once:= TRUE FI; + write term (TERM:(tcsymbolISUBt, tcargumentsISUBt, tcarityISUBt)); + t:= (tcrestISUB(t)) ; + PER. +ENDPROC write knowledge base; + +PROC write symbol (TERM CONST t): + TEXT VAR w1, w2:= name (symboltable, t.symbol); + IF quoting + THEN scan (w2); + next symbol (w1, i); INT VAR i; + IF w1 = w2 CAND i <> num + THEN write (w2) + ELSE write (""""); write (w2); write ("""") + FI + ELSE write (w2) + FI +ENDPROC write symbol; + +PROC write term backward (TERM CONST t): + IF t.arity = integer + THEN write (text (t.symbol)) + ELIF t.symbol <= cons + THEN IF t.symbol < 0 + THEN write ("_"+text(-t.symbol)) + ELSE write ("["); + write subterms backward (t, t.arguments); write ("]") + FI + ELSE + write symbol (t); + IF t.arguments <> nil + THEN compound term + FI + FI. + + compound term: + write ("("); write subterms backward (t, t.arguments); write (")"). + +ENDPROC write term backward; + +PROC write subterms backward (TERM CONST t, TERMS CONST ts): + IF ts = nil + THEN + ELSE write subterms backward (t, (tcrestISUB(ts)) ); + write term backward ( + TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts)); + IF ts <> t.arguments + THEN IF t.symbol = cons THEN write ("|") ELSE write (",") FI + FI + FI +ENDPROC write subterms backward; + +PROC write term (TERM CONST t): + IF t.arity = integer + THEN write (text (t.symbol)) + ELIF t.symbol <= cons + THEN IF t.symbol < 0 + THEN write ("_"+text(-t.symbol)) + ELSE write ("["); write terms; write ("]") + FI + ELSE + write symbol (t); + IF t.arguments <> nil + THEN compound term + FI + FI. + + compound term: + write ("("); write terms; write (")"). + + write terms: + TERMS VAR ts:= t.arguments; + WHILE ts <> nil + REP write term ( + TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts)); + ts:= tcrestISUB(ts); + IF ts <> nil + THEN IF t.symbol = cons THEN write ("|") ELSE write (",") FI + FI + PER. + +ENDPROC write term; + +PROC read consult list: + TERM VAR t; + TERMS CONST old tp:= tp; + WHILE filename read REP PER; + IF look ahead <> close bracket + THEN syntax error ("closing bracket expected") + FI; + remove token; + reset symboltable:= symboltable; + TERMS CONST ts:= tp; + tp:= old tp; + consult list (ts); + from file:= FALSE. + + filename read: + BOOL VAR was minus:= FALSE; + IF look ahead = minus + THEN remove token; + was minus:= TRUE + FI; + IF look ahead = identifier + THEN new tp (tp); + read term (t); + replace(tcsymbol,tp, t.symbol); + replace(tcarguments,tp, t.arguments); + replace(tcarity,tp, t.arity); + IF was minus THEN replace(tcarity,tp, var); + FI; + IF NOT exists (name (symboltable, (tcsymbolISUB(tp)) + )) + THEN syntax error ("file does not exist"); FALSE + ELIF look ahead = comma THEN remove token; TRUE + ELSE TRUE + FI + ELSE FALSE + FI . + + remove token: + look ahead empty:= TRUE. +ENDPROC read consult list; + +PROC consult list (TERMS CONST ts): + IF ts > tp + THEN TERM VAR term:= + TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts); + consult list (ts-1); + IF free of errors + THEN TEXT VAR fname:= name (symboltable, term.symbol); + IF term.arity = var + THEN put ("reconsulting"); putline (fname); reconsult (fname) + ELSE put ( "consulting"); putline (fname); consult (fname) + FI + FI + FI +ENDPROC consult list; + +PROC initiate read terms (TERMS VAR ts, TEXT CONST prompter): + enable stop; + look ahead empty:= TRUE; ahead empty:= TRUE; + from file:= FALSE; + TEXT VAR inputline; + IF prompter = "-" + THEN inputline:= "" + ELSE inputline:= ""13"" + FI; + REP + WHILE sysin = "" CAND is escape + REP write (""13""15"gib kommando: "); + get command; + IF inputline = "" + THEN write (""14""3""3"") + ELSE write (""14""13""10""); + IF prompter = "-" + THEN lernsequenz auf taste legen ("k", inputline); + FI; + disable stop; + lernsequenz auf taste legen ("q","break"13""); + do (inputline); + lernsequenz auf taste legen ("q","bye"13""); + IF is error + THEN put (errormessage); clear error + FI; + enable stop; + FI; + write (""13""10""5"?"); + write (prompter); + write (" ") + PER; + getline (inputline); + IF inputline <> "" + CAND (inputline SUB length (inputline)) <> "." + THEN inputline CAT "." + FI; + scan (inputline); + ts:= nil + UNTIL inputline <> "" PER; + IF prompter = "-" + THEN lernsequenz auf taste legen ("k", inputline) + FI. + + is escape: + REP IF inputline = ""13"" + THEN write (""13""10""5"?"); + write (prompter); + write (" ") + ELIF inputline = "?" + THEN putline ("?"); inform; push (""13"") + FI; + getchar (inputline) + UNTIL pos ("?"13"", inputline) = 0 + PER; + IF inputline = ""27"" + THEN getchar (inputline); + IF inputline = ""27"" + THEN TRUE + ELSE push (inputline); push (""27""); FALSE + FI + ELSE push (inputline); FALSE + FI. + + get command: + getchar (inputline); + IF inputline = ""27"" + THEN getchar (inputline); + IF inputline = ""27"" + THEN inputline:= ""; + line + ELSE push (inputline); + push (""27""); + getline (inputline) + FI + ELSE push (inputline); + getline (inputline) + FI. + +ENDPROC initiate read terms; + +PROC initiate read terms (TEXT CONST knowledge, TERMS VAR ts): + look ahead empty:= TRUE; ahead empty:= TRUE; + file:= sequential file (input, knowledge); + from file:= TRUE; + scan (file); + ts:= nil +ENDPROC initiate read terms; + +PROC read terms (TERMS VAR ts): + { the actual parameter for ts should be initiated < ts:=nil > + at top level of recursion + } + TERM VAR t; + WHILE look ahead <> close paren CAND look ahead <> close bracket + CAND look ahead <> period + REP read term (t); + append term (t, ts) + UNTIL end of list PER. + + end of list: + IF look ahead = comma + THEN remove comma; + FALSE + ELSE TRUE + FI. + + remove comma: look ahead empty:= TRUE. + +ENDPROC read terms; + +PROC read term (TERM VAR t): + IF look ahead = open paren + THEN remove token; + read term (t); + transform infix to prefix (t, 0); + IF look ahead = close paren + THEN remove token + ELSE syntax error ("closing parentheses missing") + FI + ELSE read prefix term (t); + transform infix to prefix (t, 0) + FI . + + remove token: look ahead empty:= TRUE . +ENDPROC read term; + +PROC transform infix to prefix (TERM VAR t, INT CONST last prio): + SELECT look ahead OF + CASE minus, plus, times, slash, less, equal, uneq, grt, eqeq, eqdotdot, + boldvar: + operator:= look ahead value; + IF last prio <= priority (operator) + THEN + remove token; + IF look ahead = open paren + THEN read term (t2); + ELSE read prefix term (t2); + FI; + IF last prio < priority (operator) + THEN transform infix to prefix (t2, priority (operator)); + FI; + form result; + transform infix to prefix (t, last prio) + FI + ENDSELECT. + + form result: + second operand; + first operand; + prefix. + +second operand: + TERMS VAR p2; + TERM VAR t2; + new tp (p2); + replace(tcsymbol, p2, t2.symbol); + replace(tcarguments, p2, t2.arguments); + replace(tcarity, p2, t2.arity); + replace(tcrest, p2, nil). + +first operand: + TERMS VAR p1; + new tp (p1); + replace(tcsymbol, p1, t.symbol); + replace(tcarguments, p1, t.arguments); + replace(tcarity, p1, t.arity); + replace(tcrest, p1, p2). + +prefix: + INT VAR operator; + t.symbol:= operator; + t.arguments:= p1; + t.arity:= 2. + + remove token: + look ahead empty:= TRUE. + +ENDPROC transform infix to prefix; + +INT PROC priority (INT CONST operator): + SELECT operator OF + CASE times, slash, mod: 7 + CASE minus, plus: 6 + CASE 9,10,11,12,13: 5 + OTHERWISE 2 + ENDSELECT +ENDPROC priority; + +PROC read prefix term (TERM VAR t): + SELECT look ahead OF + CASE exclamation: term is cut + CASE bold var: term is a variable + CASE underscore: term is anonym + CASE number: term is number + CASE identifier, + minus, plus, times, slash, less, equal, uneq, grt, eqeq, eqdotdot: + IF look ahead = minus + THEN remove token; + IF look ahead = number {monadic minus} + THEN look ahead value:= - look ahead value; + term is number; + LEAVE read prefix term + FI + ELSE remove token + FI; + term is identifier; + IF look ahead = open paren + THEN term is compound + { ELSE term is a constant } + FI + CASE open bracket: term is list + CASE colon: term is colon + OTHERWISE syntax error ("wrong expression"); + t:= TERM:(nil, nil, 0) + ENDSELECT. + + term is cut: + remove token; + t:= TERM:(cut, nil, 0). + + term is a variable: + remove token; + t:= TERM:(look ahead value, nil, var). + + term is anonym: + remove token; + anonym value DECR 1; + t:= TERM:(anonym value, nil, var). + + term is number: + remove token; + t:= TERM:(look ahead value, nil, integer). + + term is identifier: + t:= TERM:(look ahead value, nil, 0). + + term is list: + remove token; + t:= TERM:(nil, nil, 0); + IF look ahead = close bracket + THEN remove token + ELSE non empty list + FI. + + non empty list: + TERM VAR t1; + read term (t1); + append term (t1, t.arguments); + IF look ahead = close bracket + THEN remove token; + t.arity:= 1 + ELSE list with more than one element + FI. + + list with more than one element: + IF look ahead = stroke + THEN t.symbol:= cons + ELIF look ahead <> comma CAND look ahead <> colon + THEN syntax error ("comma missing") + FI; + term is compound list. + + term is compound list: + remove token; + read terms (t.arguments); + t.arity:= no of terms (t.arguments); + IF look ahead = close bracket + THEN remove token + ELSE syntax error ("closing bracket missing") + FI. + + term is compound: + remove token; + read terms (t.arguments); + t.arity:= no of terms (t.arguments); + IF look ahead = close paren + THEN remove token + ELSE syntax error ("closing parentheses missing") + FI. + + term is colon: + remove token; + INT VAR i:= link (symboltable, ":-"); + IF i = 0 + THEN insert (symboltable, ":-", i) + FI; + t:= TERM:(i, nil, 0). + + remove token: + look ahead empty:= TRUE. + +ENDPROC read prefix term; + +INT PROC no of terms (TERMS CONST ts): + INT VAR i:= 0, t:=ts; + WHILE t <> nil + REP t:= (tcrestISUB(t)) ; + i INCR 1 + PER; + i +ENDPROC no of terms; + +INT PROC arith (TERM CONST term, FRAME CONST curr frame): + TERM VAR t; + IF term.arity = var + THEN value (term, t, curr frame) + ELSE t:= term + FI; + IF t.arity = integer + THEN t.symbol + ELIF t.arity = var + THEN syntax error ("free variable in arith expression"); 0 + ELIF t.arity = 1 + THEN SELECT t.symbol OF + CASE plus: arith (t1, curr frame) + CASE minus: - arith (t1, curr frame) + OTHERWISE syntax error ("unknown arith operator"); 0 + ENDSELECT + ELIF t.arity = 2 + THEN SELECT t.symbol OF + CASE plus: arith (t1, curr frame) + arith (t2, curr frame) + CASE minus: arith (t1, curr frame) - arith (t2, curr frame) + CASE times: arith (t1, curr frame) * arith (t2, curr frame) + CASE slash: arith (t1, curr frame) DIV arith (t2, curr frame) + CASE mod: arith (t1, curr frame) MOD arith (t2, curr frame) + OTHERWISE syntax error ("unknown arith operator"); 0 + ENDSELECT + ELSE syntax error ("wrong arith expression"); 0 + FI. + + t1: TERM:(tcsymbolISUBt.arguments, + tcargumentsISUBt.arguments, + tcarityISUBt.arguments) . + + t2: TERM:(tcsymbolISUB(tcrestISUB(t.arguments)) , + tcargumentsISUB(tcrestISUB(t.arguments)) , + tcarityISUB(tcrestISUB(t.arguments)) ) . + +ENDPROC arith; + +TOKEN PROC look ahead : + { Returns the token in the look ahead. + If the look ahead is empty it calls the scanner + to get the next symbol, + which is then placed into the look ahead. + } + SYMBOLTYPE VAR symboltype; + IF look ahead empty + THEN look ahead empty:= FALSE; + get next symbol; + store the symbol + FI; + look ahead token. + + get next symbol: + IF ahead empty + THEN IF from file + THEN next symbol (file, look ahead symbol, symboltype) + ELSE next symbol (look ahead symbol, symboltype) + FI + ELSE ahead empty:= TRUE; + look ahead symbol:= ahead symbol; + symboltype:= ahead symboltype + FI. + + store the symbol: + SELECT symboltype OF + CASE tag,tex: look ahead token:= identifier; + IF look ahead symbol = "" + THEN look ahead value:= 0; + ELSE install + FI + CASE num: look ahead token:= number; + look ahead value:= int(look ahead symbol) + CASE bold: look ahead token:= bold var; + install + CASE operator: look ahead token:= + pos ("|!:-+*/_<=<>==..", look ahead symbol); + IF look ahead token = equal + THEN get next symbol; + IF symboltype = operator + CAND look ahead symbol = "=" + THEN look ahead token:= eqeq; + look ahead symbol:= "==" + ELIF look ahead symbol = "." + THEN get next symbol; + IF look ahead symbol = "." + THEN look ahead token:= eqdotdot; + look ahead symbol:= "=.." + ELSE syntax error ("second period missing") + FI + ELSE ahead symbol:= look ahead symbol; + ahead symboltype:= symboltype; + ahead empty:= FALSE; + look ahead symbol:= "="; + look ahead token := equal + FI + FI; + IF look ahead token > 3 + THEN install + FI + CASE delimiter: look ahead token:= + pos ("|!:-+*/_<=<>==..,;()[]", look ahead symbol); + SELECT look ahead token OF + CASE colon: minus must follow + CASE 0: syntax error ("wrong delimiter") + ENDSELECT + CASE endoffile: look ahead token:= end of input + CASE within com: look ahead token:= end of input; + syntax error ("within comment") + CASE within tex: look ahead token:= end of input; + syntax error ("within text") + ENDSELECT. + + minus must follow: + get next symbol; + IF look ahead symbol <> "-" + THEN syntax error ("minus after colon expected") FI. + + install: + look ahead value:= link (symboltable, look ahead symbol); + IF look ahead value = 0 + THEN insert(symboltable,look ahead symbol,look ahead value) + FI. +ENDPROC look ahead; + +PROC inform: + enable stop; + put (" "); + put (clock(0) - start time); put ("SEC"); + IF inference count > 0 CAND clock(0) > start time + THEN + put (inference count); put ("inferences"); + put (int (real (inference count) / (clock(0) - start time))); + put ("LIPS") + FI; + FOR k FROM 2 UPTO fsp + REP line; + FRAME CONST f:= fsc(k).frame; + INT CONST ind:= fc(f).level; + IF ind <= 40 + THEN write (ind*" ") + ELSE write (text(ind) + ": ") + FI; + value (fc(f).call, t, fc(f).father); + write term backward (t) + PER; + IF testing + THEN put(tp); put(kp); put(fp); put(fsp); put(np); put(ep) + FI; + line +ENDPROC inform; + +PROC syntax error (TEXT CONST message): + free of errors:= FALSE; + write ("!- "); + write note (message); + write note (" at '"); + write note (look ahead symbol); + write note ("' "); + IF from file + THEN write note ("in rule "); write note (rule count); + write note ("line "); write note (lineno(file) - 1) + FI; + look ahead empty:= TRUE; + line; note line +ENDPROC syntax error; + +PROC write note (TEXT CONST t): + write (t); + IF from file THEN note (t) FI +ENDPROC write note; + +PROC write note (INT CONST i): + put (i); + IF from file THEN note (i) FI +ENDPROC write note; + +PROC trace (TEXT CONST on): + testing:= test on; + tracing:= trace on. + trace on: pos (on, "on") > 0. + test on : pos (on, "test") > 0 +ENDPROC trace; + +PROC new kp (INT VAR pointer): + kp INCR 1; pointer:= kp; + IF length (kcfirst) < 2*kp + THEN IF kp > 15990 + THEN pegel overflow + ELSE kcfirst CAT "1234567890123456"; + kcrest CAT "1234567890123456"; + FI FI +ENDPROC new kp; + +PROC new tp (INT VAR pointer): + tp INCR 1; pointer:= tp; + IF length (tcsymbol) < 2*tp + THEN IF tp = 15990 + THEN pegel overflow + ELSE tcsymbol CAT "1234567890123456"; + tcarguments CAT "1234567890123456"; + tcarity CAT "1234567890123456"; + tcrest CAT "1234567890123456" + FI FI +ENDPROC new tp; + +PROC new (INT VAR pegel, pointer): + IF pegel = limit + THEN pegel overflow + ELSE pegel INCR 1; pointer:= pegel + FI +ENDPROC new; + +PROC pegeloverflow: line; write (" "); + put(tp); put(kp); put(fp); put(fsp); put(np); put(ep); + errorstop ("pegeloverflow") +ENDPROC pegeloverflow; + + +{ +Programmtransformation: + + PASCAL mit Pointer ==> ELAN + + +1. Rekursive Datentypen: + + type t = ^tcell; ==> LET T = INT; + + { schwache Datenabstraktion mit LET ist besser, + weil keine neuen Zugriffsprozeduren erforderlich. + + GLOBAL: + } + LET nil = 0, limit <= 500; + ROW limit TCELL VAR tc; { t cell } + INT VAR tp:= nil; { t pegel } + + +2. Deklaration: + + var x : t; ==> T VAR x; { Type checking selber machen ! } + + +3. Pointer-Initialisierung: + + x:= nil; ==> x:= nil; + + +4. Allokation: + + new (x); ==> new (tp,x); + + dispose (x); ==> kommt nicht vor + + +5. Applikation: + + x^.feld ==> TERMSCELL:(TERM:(tcsymbolISUBx, tcargumentsISUBx, tcarityISUBx), tcrestISUBx).feld + + WITH ==> Refinement verwenden + +{ Programmtransformation ROW limit TERMSCELL VAR tc => TEXT VAR } + T1; + "new (tp, " CA "new tp ("; + T1; + REP + col(1); + D "tc("; + IF at ("tc(tc(") + THEN D "tc("; + attest; + col(1); + D "tc(" + FI; + attest + UNTIL eof PER +. +attest: +IF at ("tc("+any**1+").first."+any**2+":="+any**3+";"+any**4) +THEN C ("replace(tc"+match(2)+","+match(1)+","+match(3)+");"+match(4)) +ELIF at ("tc("+any**1+").rest:="+any**3+";"+any**4) +THEN C ("replace(tcrest,"+match(1)+","+match(3)+");"+match(4)) +ELIF at ("tc("+any**1+").first:="+any**3+";"+any**4) +THEN C ("replace(tcsymbol,"+match(1)+","+match(3)+ + ".symbol); replace(tcarguments,"+match(1)+","+match(3)+ + ".arguments); replace(tcarity,"+match(1)+","+match(3)+ + ".arity);"+match(4)) +ELIF at ("tc("+any**1+").first."+any**2+" "+any**4) +THEN C ("(tc"+match(2)+"ISUB("+match(1)+")) "+match(4)) +ELIF at ("tc("+any**1+").rest"+any**4) +THEN C ("(tcrestISUB("+match(1)+")) "+match(4)) +ELIF at ("tc("+any**1+").first).first"+any**4) +THEN C ("TERM:(tcsymbolISUB"+match(1)+ + ").first, tcargumentsISUB"+match(1)+ + ").first, tcarityISUB"+match(1)+").first)"+match(4)) +ELIF at ("tc("+any**1+").first"+any**4) +THEN C ("TERM:(tcsymbolISUB"+match(1)+ + ", tcargumentsISUB"+match(1)+", tcarityISUB"+match(1)+")"+match(4)) +ELIF at ("tc("+any**1+"):= TERMSCELL:("+any**2+","+any**3+")"+any**4) +THEN C ("replace(tcsymbol,"+match(1)+","+match(2)+ + ".symbol); replace(tcarguments,"+match(1)+","+match(2)+ + ".arguments); replace(tcarity,"+match(1)+","+match(2)+ + ".arity); replace(tcrest,"+match(1)+","+match(3)+")"+match(4)) +ELIF at ("tc("+any**1+")"+any**4) +THEN C ("TERMSCELL:(TERM:(tcsymbolISUB"+match(1)+ + ", tcargumentsISUB"+match(1)+", tcarityISUB"+match(1) + +"), tcrestISUB"+match(1)+")" +match(4)) +ELIF NOT eof +THEN stop +FI; +col(col-1); D("*"); C "" +. + +} + +END PACKET prolog; + +{ TEST } +lernsequenz auf taste legen ("7",""124""); +lernsequenz auf taste legen ("ü",""91""); +lernsequenz auf taste legen ("+",""93""); + diff --git a/lang/prolog/1.8.7/src/prolog installation b/lang/prolog/1.8.7/src/prolog installation new file mode 100644 index 0000000..cc674fa --- /dev/null +++ b/lang/prolog/1.8.7/src/prolog installation @@ -0,0 +1,117 @@ +(*************************************************************************) +(*** Insertiert die für PROLOG benötigten Pakete und holt die ***) +(*** Beispiele vom Archiv. ***) +(*** ***) +(*** Autor : W. Metterhausen Stand : 03.12.87 ***) +(*************************************************************************) + +erste bildschirmmeldung; + + +IF yes("Prolog insertieren?") + + THEN + hole sourcen vom archiv; + insertiere alle pakete; + hole beispiele vom archiv; + forget ("prolog installation", quiet); + type("push(""bye""13""prolog again"");prolog(""standard"")"13""); +FI. + + +insertiere alle pakete : + insert and say ("thesaurus"); + insert and say ("prolog"). + +erste bildschirmmeldung : + page; + put center (" Generator für Prolog gestartet."); line; + put center ("--------------------------------------------------");line; + put center (" Prolog kann nur in einer Task aufgebaut werden, ");line; + put center (" die nicht bereits umfangreiche insertierte Pakete ");line; + put center (" enthält! Gegebenenfalls sollte Prolog in ");line; + put center (" einer Task direkt unter ""UR"" angelegt werden. ");line; + line (2). + +hole sourcen vom archiv : + TEXT VAR datei; + datei := "thesaurus"; hole wenn noetig; + datei := "prolog"; hole wenn noetig; + line. + +hole beispiele vom archiv : + datei := "standard"; hole wenn noetig; + datei := "sum"; hole wenn noetig; + datei := "permute"; hole wenn noetig; + datei := "family"; hole wenn noetig; + datei := "puzzle"; hole wenn noetig; + datei := "calc"; hole wenn noetig; + datei := "prieks"; hole wenn noetig; + datei := "topographie"; hole wenn noetig; + datei := "quicksort"; hole wenn noetig; + datei := "prolog dokumentation"; + hole wenn noetig; + release(archive); + line. + +hole wenn noetig : + IF NOT exists (datei) THEN + put line (""""+ datei + """ wird vom Archiv geholt"); + fetch (datei, archive) + FI. + +PROC insert and say (TEXT CONST datei) : + + INT VAR cx, cy; + put line ("Inserting """ + datei + """..."); + get cursor (cx, cy); + checkoff; + insert (datei); + checkon; + cl eop (cx, cy); line; + forget (datei, quiet). + +END PROC insert and say; + +TEXT PROC inverse (TEXT CONST t): + ""15"" + t + " " + ""14"" +END PROC inverse; + +PROC put center (TEXT CONST t): + put center (t, 80) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t): + put center (zeile, t, 80) +END PROC put center; + +PROC put center (TEXT CONST t, INT CONST gesamtbreite): + INT VAR cy; + get cursor (cy, cy); + put center (cy, t, gesamtbreite) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite): + cursor ((gesamtbreite - length (t)) DIV 2, zeile); + put (t). +END PROC put center; + +PROC cl eol: + out (""5"") +END PROC cl eol; + +PROC cl eop: + out (""4"") +END PROC cl eop; + +PROC cl eol (INT CONST cx, cy): + cursor (cx, cy); + cl eol +END PROC cl eol; + +PROC cl eop (INT CONST cx, cy): + cursor (cx, cy); + cl eop +END PROC cl eop; + + diff --git a/lang/prolog/1.8.7/src/puzzle b/lang/prolog/1.8.7/src/puzzle new file mode 100644 index 0000000..648beb6 --- /dev/null +++ b/lang/prolog/1.8.7/src/puzzle @@ -0,0 +1,24 @@ + {Solution: 9,5,6,7,0,8,2} +puzzle:- repeat, permute ((9,8,7,6,5,2,0), SENDMORY), + write (SENDMORY), + puzzle (SENDMORY, SEND, MORE, MONEY), + elan (line), + write (SEND), write (+), + write (MORE), write (=), + write (MONEY). + +puzzle([S,E,N,D,O,R,Y], SEND, MORE, MONEY):- + SEND IS ((S * 10 + E) * 10 + N) * 10 + D, + MORE IS ((10 + O) * 10 + R) * 10 + E, + MONEY IS (((10 + O) * 10 + N) * 10 + E) * 10 + Y, + MONEY IS SEND + MORE. + +permute ([], []). +permute ([E|X], Z):- permute (X, Y), insert (E, Y, Z). + +insert (E, X, [E|X]). +insert (E, [F|X], [F|Y]):- insert (E, X, Y). + +repeat. +repeat:- repeat. + diff --git a/lang/prolog/1.8.7/src/quicksort b/lang/prolog/1.8.7/src/quicksort new file mode 100644 index 0000000..79276c0 --- /dev/null +++ b/lang/prolog/1.8.7/src/quicksort @@ -0,0 +1,14 @@ +(* quicksort algorithm nach Clocksin-Mellish *) + +(* Example : quicksort ([1,3,2,4], [1,2,3,4], []) *) + +quicksort ([H|T], S, X) :- + split (H, T, A, B), + quicksort (A, S, [H|Y]), + quicksort (B, Y, X). +quicksort ([], X, X). + +split (H, [A|X], [A|Y], Z) :- A <= H, split (H, X, Y, Z). +split (H, [A|X], Y, [A|Z]) :- split (H, X, Y, Z). +split (_, [], [], []). + diff --git a/lang/prolog/1.8.7/src/standard b/lang/prolog/1.8.7/src/standard new file mode 100644 index 0000000..bc983ca --- /dev/null +++ b/lang/prolog/1.8.7/src/standard @@ -0,0 +1,35 @@ +abolish (X) :- elan (abolish, X). +append ([], X, X) :- !. +append ([X|Y], Z, [X|W]) :- append (Y, Z, W). +atom (X) :- functor (X, Y, 0). +atomic (X) :- atom (X); integer (X). +consult (X) :- elan (consult, X). +end :- bye. +fail :- []. +findall (X, Y, Z) :- tell ("$$"), write ("[ "), findall (X,Y); + write (" ]"), told, see ("$$"), read (Z), + seen, elan (forget, "$$"). +findall (X, Y) :- call (Y), writeq (X), write (","), []. +integer (X) :- functor (X, Y, -1). +listing (X). +member (X, [X|Z]). +member (X, [Y|Z]) :- member (X, Z). +nl :- elan (line). +non var (X) :- var (X), !, []; . +not (X) :- call (X), !, []; . +notrace :- elan (trace, off). +reconsult (X) :- elan (reconsult, X). +repeat. +repeat :- repeat. +see (X) :- elan (sysin, X). +seen :- elan (sysin, ""). +tab (X) :- tab(X,1). +tab (X,Y) :- Y<=X, !, put (32), incr(Y), tab(X,Y);. +tell (X) :- elan (sysout, X). +told :- elan (sysout, ""). +trace :- elan (trace, on). +true. +< (X, Y) :- <= (X, Y), <> (X, Y). +> (X, Y) :- <= (Y, X). +>= (X, Y) :- < (Y, X). + diff --git a/lang/prolog/1.8.7/src/sum b/lang/prolog/1.8.7/src/sum new file mode 100644 index 0000000..e1b6b13 --- /dev/null +++ b/lang/prolog/1.8.7/src/sum @@ -0,0 +1,13 @@ +suc (0, 1). suc (1, 2). suc (2, 3). suc (3, 4). suc (4, 5). +suc (5, 6). suc (6, 7). suc (7, 8). suc (8, 9). +sum (0, X, X). +sum (X, Y, Z):- suc (V, X), sum (V, Y, W), suc (W, Z). +plus (X, [0,0], X):- !. +plus (X, Y, Z):- plus one (V, Y), plus (X, V, W), !, plus one (W, Z). +plus one ([X, Y], [V, W]):- suc (Y, W), X = V, !; + Y = 9, suc (X, V), W = 0. +treereverse (X,Y):- rev (X,Y), !; rev (Y,X), !. +rev ([], []). +rev ([X|Y], Z):- X <> [H|T], rev (Y, W), !, append (W, [X], Z); + rev (X, V), rev (Y, W), !, append (W, [V], Z). + diff --git a/lang/prolog/1.8.7/src/thesaurus b/lang/prolog/1.8.7/src/thesaurus new file mode 100644 index 0000000..4694981 --- /dev/null +++ b/lang/prolog/1.8.7/src/thesaurus @@ -0,0 +1,360 @@ +(* ------------------- VERSION 2 19.01.87 ------------------- *) +PACKET thesaurus handling (* Autor: J.Liedtke *) + + DEFINES THESAURUS , + := , + empty thesaurus , + insert, (* fuegt ein Element ein *) + delete, (* loescht ein Element falls vorhanden *) + rename, (* aendert ein Element falls vorhanden *) + CONTAINS , (* stellt fest, ob enthalten *) + link , (* index in thesaurus *) + name , (* name of entry *) + decode invalid chars ,(* Steuerzeichen dekodieren *) + get , (* get next entry ("" is eof) *) + highest entry : (* highest valid index of thes *) + + +TYPE THESAURUS = TEXT ; + +LET nil = 0 , + niltext = "" , + max name length = 80 , + begin entry char = ""0"" , + end entry char = ""255"" , + nil entry = ""0""255"" , + nil name = "" , + quote = """" ; + +TEXT VAR entry , + dummy ; +INT VAR cache index := 0 , + cache pos ; + + +TEXT PROC decode (INT CONST number) : + + dummy := " " ; + replace (dummy, 1, number) ; + dummy . + +ENDPROC decode ; + +INT PROC decode (TEXT CONST string, INT CONST position) : + + subtext (string, position, position + 1) ISUB 1 . + +ENDPROC decode ; + +PROC access (THESAURUS CONST thesaurus, TEXT CONST name) : + + construct entry ; + IF NOT cache identifies entry + THEN search through thesaurus list + FI ; + IF entry found + THEN cache index := decode (list, cache pos - 2) + ELSE cache index := 0 + FI . + +construct entry : + entry := begin entry char ; + entry CAT name ; + decode invalid chars (entry, 2) ; + entry CAT end entry char . + +search through thesaurus list : + cache pos := pos (list, entry) . + +cache identifies entry : + cache pos <> 0 AND + pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos . + +entry found : cache pos > 0 . + +list : CONCR (thesaurus) . + +ENDPROC access ; + +PROC access (THESAURUS CONST thesaurus, INT CONST index) : + + IF cache identifies index + THEN cache index := index ; + construct entry + ELSE cache pos := pos (list, decode (index) + begin entry char) ; + IF entry found + THEN cache pos INCR 2 ; + cache index := index ; + construct entry + ELSE cache index := 0 ; + entry := niltext + FI + FI . + +construct entry : + entry := subtext (list, cache pos, pos (list, end entry char, cache pos)) . + +cache identifies index : + subtext (list, cache pos-2, cache pos) = decode (index) + begin entry char . + +entry found : cache pos > 0 . + +list : CONCR (thesaurus) . + +ENDPROC access ; + + + +THESAURUS PROC empty thesaurus : + + THESAURUS : (""1""0"") + +ENDPROC empty thesaurus ; + + +OP := (THESAURUS VAR dest, THESAURUS CONST source ) : + + CONCR (dest) := CONCR (source) . + +ENDOP := ; + +TEXT VAR insert name ; + +PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) : + + insert name := name ; + decode invalid chars (insert name, 1) ; + insert name if possible . + +insert name if possible : + IF insert name = "" OR LENGTH insert name > max name length + THEN index := nil ; errorstop ("Name unzulaessig") + ELIF overflow + THEN index := nil + ELSE insert element + FI . + +overflow : + LENGTH CONCR (thesaurus) + LENGTH insert name + 4 > max text length . + +insert element : + search free entry ; + IF entry found + THEN insert into directory + ELSE add entry to directory if possible + FI . + +search free entry : + access (thesaurus, nil name) . + +insert into directory : + change (list, cache pos + 1, cache pos, insert name) ; + index := cache index . + +add entry to directory if possible : + INT CONST next free index := decode (list, LENGTH list - 1) ; + add entry to directory . + +add entry to directory : + list CAT begin entry char ; + cache pos := LENGTH list ; + cache index := next free index ; + list CAT insert name ; + list CAT end entry char + decode (next free index + 1) ; + index := cache index . + +entry found : cache index > 0 . + +list : CONCR (thesaurus) . + +ENDPROC insert ; + +PROC decode invalid chars (TEXT VAR name, INT CONST start pos) : + + INT VAR invalid char pos := pos (name, ""0"", ""31"", start pos) ; + WHILE invalid char pos > 0 REP + change (name, invalid char pos, invalid char pos, decoded char) ; + invalid char pos := pos (name, ""0"", ""31"", invalid char pos) + PER ; + change all (name, ""255"", quote + "255" + quote) . + +decoded char : quote + text(code(name SUB invalid char pos)) + quote. + +ENDPROC decode invalid chars ; + +PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) : + + INT VAR index ; + insert (thesaurus, name, index) ; + IF index = nil AND NOT is error + THEN errorstop ("THESAURUS-Ueberlauf") + FI . + +ENDPROC insert ; + +PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) : + + access (thesaurus, name) ; + index := cache index ; + delete (thesaurus, index) . + +ENDPROC delete ; + +PROC delete (THESAURUS VAR thesaurus, INT CONST index) : + + access (thesaurus, index) ; + IF entry found + THEN delete entry + FI . + +delete entry : + IF is last entry of thesaurus + THEN cut off as much as possible + ELSE set to nil entry + FI . + +set to nil entry : + change (list, cache pos, cache pos + LENGTH entry - 1, nil entry) . + +cut off as much as possible : + WHILE predecessor is also nil entry REP + set cache to this entry + PER ; + list := subtext (list, 1, cache pos - 1) ; + erase cache . + +predecessor is also nil entry : + subtext (list, cache pos - 4, cache pos - 3) = nil entry . + +set cache to this entry : + cache pos DECR 4 . + +erase cache : + cache pos := 0 ; + cache index := 0 . + +is last entry of thesaurus : + pos (list, end entry char, cache pos) = LENGTH list - 2 . + +list : CONCR (thesaurus) . + +entry found : cache index > nil . + +ENDPROC delete ; + + +BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) : + + IF name = niltext OR LENGTH name > max name length + THEN FALSE + ELSE access (thesaurus, name) ; entry found + FI . + +entry found : cache index > nil . + +ENDOP CONTAINS ; + +PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) : + + rename (thesaurus, link (thesaurus, old), new) + +ENDPROC rename ; + +PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) : + + insert name := new ; + decode invalid chars (insert name, 1) ; + IF overflow + THEN errorstop ("THESAURUS-Ueberlauf") + ELIF insert name = "" OR LENGTH insert name > max name length + THEN errorstop ("Name unzulaessig") + ELSE change to new name + FI . + +overflow : + LENGTH CONCR (thesaurus) + LENGTH insert name + 4 > max text length . + +change to new name : + access (thesaurus, index) ; + IF cache index <> 0 AND entry <> "" + THEN change (list, cache pos + 1, cache pos + LENGTH entry - 2, insert name) + FI . + +list : CONCR (thesaurus) . + +ENDPROC rename ; + +INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) : + + access (thesaurus, name) ; + cache index . + +ENDPROC link ; + +TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) : + + access (thesaurus, index) ; + subtext (entry, 2, LENGTH entry - 1) . + +ENDPROC name ; + +PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) : + + identify index ; + REP + to next entry + UNTIL end of list COR valid entry found PER . + +identify index : + IF index = 0 + THEN cache index := 0 ; + cache pos := 1 + ELSE access (thesaurus, index) + FI . + +to next entry : + cache pos := pos (list, begin entry char, cache pos + 1) ; + IF cache pos > 0 + THEN correct cache pos ; + get entry + ELSE get nil entry + FI . + +correct cache pos : + IF (list SUB cache pos + 2) = begin entry char + THEN cache pos INCR 2 + ELIF (list SUB cache pos + 1) = begin entry char + THEN cache pos INCR 1 + FI . + +get entry : + cache index INCR 1 ; + index := cache index ; + name := subtext (list, cache pos + 1, end entry pos - 1) . + +get nil entry : + cache index := 0 ; + cache pos := 0 ; + index := 0 ; + name := "" . + +end entry pos : pos (list, end entry char, cache pos) . + +end of list : index = 0 . + +valid entry found : name <> "" . + +list : CONCR (thesaurus) . + +ENDPROC get ; + +INT PROC highest entry (THESAURUS CONST thesaurus) : (*840813*) + + decode (list, LENGTH list - 1) - 1 . + +list : CONCR (thesaurus) . + +ENDPROC highest entry ; + +ENDPACKET thesaurus handling ; + diff --git a/lang/prolog/1.8.7/src/topographie b/lang/prolog/1.8.7/src/topographie new file mode 100644 index 0000000..c0924cf --- /dev/null +++ b/lang/prolog/1.8.7/src/topographie @@ -0,0 +1,59 @@ +member(X,[X|_]). +member(X,[_|Y]):- + member(X,Y). + +append([],L,L). +append([X|A],B,[X|C]):- + append(A,B,C). + +efface(A,[A|L],L):- + !. +efface(A,[B|L],[B|M]):- + efface(A,L,M). +efface(_,[],[]). + + +nol(N):- + read(N). + +input(_,_,N,N,L,L). +input(X,Y,R,N,L,O):- + read(X), + read(Y), + append([[X,Y]],L,M), + C IS R+1, + input(_,_,C,N,M,O). + +enter(L):- + nol(N), + input(X,Y,0,N,[],L). + + +searchnext(X,Y,[H|T]):- + H=[X,Y]; + H=[Y,X]; + searchnext(X,Y,T). + +onemove(_,_,[],L):- + write(L). +onemove(X,Y,L,H):- + searchnext(X,Y,L), + efface([X,Y],L,N), + L<>N, + write(N),elan(line), + append(H,[Y],F), + onemove(Y,Z,N,F). +onemove(X,Y,L,H):- + searchnext(X,Y,L), + efface([Y,X],L,N), + L<>N, + write(N),elan(line), + append(H,[Y],F), + onemove(Y,Z,N,F). + + + +go:- + enter(L),!, + onemove(X,Y,L,[X]). + |