From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- lang/lisp/1.8.7/src/lisp.3 | 767 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 767 insertions(+) create mode 100644 lang/lisp/1.8.7/src/lisp.3 (limited to 'lang/lisp/1.8.7/src/lisp.3') 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; + + + -- cgit v1.2.3