summaryrefslogtreecommitdiff
path: root/lisp/lisp.1
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/lisp.1')
-rw-r--r--lisp/lisp.11306
1 files changed, 1306 insertions, 0 deletions
diff --git a/lisp/lisp.1 b/lisp/lisp.1
new file mode 100644
index 0000000..32a9c27
--- /dev/null
+++ b/lisp/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;
+