lisp-interpreter.a68
1 @section Synopsis
2
3 Miniature LISP interpreter in Algol 68.
4
5 #
6
7 # Data structure to represent a list #
8
9 MODE NUMBER = LONG INT,
10 VALUE = UNION (ATOM, LIST),
11 ATOM = STRING,
12 LIST = REF NODE,
13 NODE = STRUCT (VALUE car, cdr);
14
15 LIST nil = NIL;
16
17 PROC error = (STRING t) VOID: print ((new line, "error: ", t));
18
19 PROC is atom = (VALUE v) BOOL: (v | (ATOM): TRUE | FALSE);
20
21 PROC is nil = (VALUE v) BOOL: (v | (LIST l): l :=: nil | FALSE);
22
23 PROC number = (VALUE v) NUMBER:
24 CASE v
25 IN (ATOM a): BEGIN NUMBER sum := 0, weight := 1;
26 FOR i FROM UPB a BY -1 TO LWB a
27 DO sum +:= weight * (ABS a[i] - ABS "0");
28 weight *:= 10
29 OD;
30 sum
31 END,
32 (LIST l): (is nil (l) | error ("numeral of nil"); 0 | number (CAR l))
33 ESAC;
34
35 PROC atom = (NUMBER n) ATOM: whole (n, 0);
36
37 OP CONS = (VALUE v, w) VALUE: HEAP NODE := (v, w), PRIO CONS = 9;
38
39 OP + = (VALUE v, w) VALUE:
40 CASE v
41 IN (ATOM a): v CONS (w | (ATOM): w, (LIST): CAR w),
42 (LIST k): IF is nil (k)
43 THEN w
44 ELIF is nil (CDR k)
45 THEN CAR k CONS (w | (ATOM): w, (LIST): CAR w)
46 ELSE CAR k CONS (CDR k + w)
47 FI
48 ESAC;
49
50 OP CAR = (VALUE v) VALUE:
51 CASE v
52 IN (ATOM): (error ("car of atom"); nil),
53 (LIST l): (l :=: nil | error ("car of nil"); nil | car OF l)
54 ESAC;
55
56 OP CDR = (VALUE v) VALUE:
57 CASE v
58 IN (ATOM): (error ("cdr of atom"); nil),
59 (LIST l): (l :=: nil | error ("cdr of nil"); nil | cdr OF l)
60 ESAC;
61
62 OP EQ = (VALUE v, w) BOOL:
63 CASE v
64 IN (ATOM a): (w | (ATOM b): a = b | FALSE),
65 (LIST l): (w | (LIST k): l :=: k | FALSE)
66 ESAC;
67
68 PROC print list = (LIST l) VOID:
69 CASE print value (CAR l);
70 CDR l
71 IN (ATOM a): (print (blank); print value (a)),
72 (LIST k): (~ is nil (k) | print (blank); print list (k))
73 ESAC;
74
75 PROC print value = (VALUE v) VOID:
76 CASE v
77 IN (ATOM a): print (a),
78 (LIST l): (is nil (l) | print ("nil") | (print ("("); print list (l); print (")")))
79 ESAC;
80
81 PROC interpret = (ATOM cmd, VALUE args) VALUE:
82 IF cmd = "'"
83 THEN CAR args
84 ELIF cmd = "+"
85 THEN atom (number (eval (CAR args)) + number (eval (CDR args)))
86 ELIF cmd = "-"
87 THEN atom (number (eval (CAR args)) - number (eval (CDR args)))
88 ELIF cmd = "*"
89 THEN atom (number (eval (CAR args)) * number (eval (CDR args)))
90 ELIF cmd = "/"
91 THEN atom (number (eval (CAR args)) OVER number (eval (CDR args)))
92 ELIF cmd = "append"
93 THEN CAR args + CDR args
94 ELIF cmd = "eval"
95 THEN eval (args)
96 ELIF cmd = "quit"
97 THEN stop
98 ELSE cmd CONS args
99 FI;
100
101 PROC eval = (VALUE v) VALUE:
102 CASE v
103 IN (ATOM a): a,
104 (LIST k): IF is nil (k)
105 THEN nil
106 ELSE CASE CAR k
107 IN (ATOM a): interpret (a, CDR k),
108 (LIST l): eval (CAR k) CONS eval (CDR k)
109 ESAC
110 FI
111 ESAC;
112
113 # Construct a value from a string of LISP symbols #
114
115 PROC parse = (STRING s) VALUE:
116 BEGIN MODE STACK = STRUCT (STRING elem, REF STACK next);
117 REF STACK stack := NIL;
118
119 PROC pop = VOID:
120 stack := next OF stack;
121
122 PROC push = (STRING s) VOID:
123 stack := HEAP STACK := (s, stack);
124
125 PROC top = STRING:
126 elem OF stack;
127
128 INT i := UPB s;
129 WHILE i > LWB s
130 DO WHILE i > LWB s ANDF s[i] = " " DO i -:= 1 OD;
131 INT j = i;
132 WHILE i >= LWB s ANDF s[i] ~= " " DO i -:= 1 OD;
133 IF i + 1 <= j
134 THEN push (s[i + 1 .. j])
135 FI
136 OD;
137
138 PROC make value = VALUE:
139 IF stack :=: REF STACK (NIL)
140 THEN nil
141 ELIF top = "("
142 THEN pop;
143 VALUE left value := make value;
144 left value CONS make value
145 ELIF top = ")"
146 THEN pop;
147 nil
148 ELSE VALUE left value := HEAP ATOM := top;
149 pop;
150 left value CONS make value
151 FI;
152
153 make value
154 END;
155
156 FILE f;
157 VOID (open (f, program idf, standin channel));
158 get (f, new line);
159 DO STRING s;
160 get (f, (s, new line));
161 VALUE l := parse (s);
162 print (">");
163 print value (l);
164 new line (stand out);
165 print value (eval (l));
166 new line (stand out)
167 OD
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
