path: root/lang/lisp/1.8.7/src/lisp.1

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;