summaryrefslogtreecommitdiff
path: root/lang/lisp
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
committerLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
commit04e68443040c7abad84d66477e98f93bed701760 (patch)
tree2b6202afae659e773bf6916157d23e83edfa44e3 /lang/lisp
downloadeumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.gz
eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.bz2
eumel-src-04e68443040c7abad84d66477e98f93bed701760.zip
Initial import
Diffstat (limited to 'lang/lisp')
-rw-r--r--lang/lisp/1.7.2/src/lisp.11305
-rw-r--r--lang/lisp/1.7.2/src/lisp.2550
-rw-r--r--lang/lisp/1.7.2/src/lisp.3142
-rw-r--r--lang/lisp/1.7.2/src/lisp.4766
-rw-r--r--lang/lisp/1.7.2/src/lisp.bootstrap117
-rw-r--r--lang/lisp/1.8.7/doc/lisp handbuch2260
-rw-r--r--lang/lisp/1.8.7/source-disk1
-rw-r--r--lang/lisp/1.8.7/src/"15"TAB2"14"bin0 -> 22528 bytes
-rw-r--r--lang/lisp/1.8.7/src/lisp.11306
-rw-r--r--lang/lisp/1.8.7/src/lisp.2584
-rw-r--r--lang/lisp/1.8.7/src/lisp.3767
-rw-r--r--lang/lisp/1.8.7/src/lisp.4143
-rw-r--r--lang/lisp/1.8.7/src/lisp.bootstrap118
13 files changed, 8059 insertions, 0 deletions
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"
new file mode 100644
index 0000000..654b374
--- /dev/null
+++ b/lang/lisp/1.8.7/src/"15"TAB2"14"
Binary files differ
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))))
+ )
+)
+