tree checksum vpatch file split hunks

all signers: spyked

antecedents:

press order:

adalisp_genesisspyked

patch:

-
+ 74C1E88D5AF7EEC476C54F9C879514C63EE0BFF3B9354A36AB282DFC6CD010E0F8E9C89FF091732859CC18238F467EFBE35959BF9A4445A422012536E899403F
adalisp/README
(0 . 0)(1 . 33)
5 README
6
7 `adalisp` is an interpreter for a small Lisp-like scripting language
8 that aims to a. fit in head, while b. being written in a small,
9 restricted, safe subset of the `Ada` programming language. For more
10 details, see:
11
12 http://thetarpit.org/posts/y04/074-adalisp-prototype.html
13
14 ---
15 To INSTALL `adalisp`:
16
17 * Install an `Ada` distribution; `adalisp` was tested on GNAT GPL
18 2016.
19
20 * Use `V` to press:
21
22 mkdir ~/src/adalisp
23 cd ~/src/adalisp
24
25 mkdir .wot
26 cd .wot && wget http://lucian.mogosanu.ro/spyked.asc && cd ..
27
28 v.pl init http://lucian.mogosanu.ro/src/adalisp
29 v.pl press adalisp_genesis adalisp_genesis.vpatch
30
31 ---
32 To BUILD and USE `adalisp`:
33
34 cd ~/src/adalisp/adalisp_genesis/adalisp
35 gprbuild
36
37 cat test.scm | ./bin/test_repl
-
+ 86525F2C7086039D79E5BF92869D02934A44716812433CA3A90E18A8D03745785C5CA54FE8C39E681B3B13C00C33A5128884A28C8CBACCBC65D0B401D901EC2E
adalisp/bin/README
(0 . 0)(1 . 1)
42 Placeholder.
-
+ 7C90ED5668838EEBB2F201AB981083B05AF9A9E39946B11914B7CD81E66CE5DD8B2B11246E6FDA73F9DFC96CA9645CEE9F6B7D5AE5791320330C3501DA302E7A
adalisp/manifest
(0 . 0)(1 . 1)
47 530176 adalisp_genesis spyked Lucian's first adalisp iteration
-
+ 86525F2C7086039D79E5BF92869D02934A44716812433CA3A90E18A8D03745785C5CA54FE8C39E681B3B13C00C33A5128884A28C8CBACCBC65D0B401D901EC2E
adalisp/obj/README
(0 . 0)(1 . 1)
52 Placeholder.
-
+ 97B22557F90FE3BB7B5889A5976AFEE0788CC7063F955194BB78287D7C4A6924F99A400271A0DB241DA7D19C4F210AF1AFDA511E533C4B9C20A956BE87C9F6DD
adalisp/src/evaler.adb
(0 . 0)(1 . 1014)
57 -- LispM evaluator implementation.
58
59 with Ada.Text_IO; use Ada.Text_IO; -- for error reporting
60
61 package body Evaler is
62
63 -- An accumulator register for arithmetic/logic ops.
64 ALU_Acc : Long_Integer := 0;
65
66 -- Apply arithmetic and logic function, i.e. +, -, * or /
67 procedure Apply_ALU_Func(Func : in ALUFunc;
68 Args : in MemPtr;
69 Env : in MemPtr; OutP : out MemPtr) is
70 P, CarP : MemPtr;
71 begin
72 -- General form: (f e1 e2 ...) where f is one of +, -, * or
73 -- /. Special cases:
74 --
75 -- - (+) --> 0
76 -- - (- x) --> -x
77 -- - (*) --> 1
78 -- - (/ x) --> 1/x (always 0 for Fixnums)
79
80 -- Initialize loop variables and perform argument count checks
81 -- where needed.
82 P := Args;
83 case Func is
84 when ALU_Add =>
85 -- Identity element for +
86 ALU_Acc := 0;
87 when ALU_Sub =>
88 -- - needs at least one argument
89 pragma Assert(P /= 0, "- needs at least 1 argument");
90 CarP := Get_Car(AMem(P));
91 P := Get_Cdr(AMem(P));
92
93 -- (- x) is arithmetic negation; (- x y ...) is equivalent
94 -- to x - y - ...
95 if (P = 0) then
96 ALU_Acc := -Get_Fixnum(AMem(CarP));
97 else
98 ALU_Acc := Get_Fixnum(AMem(CarP));
99 end if;
100 when ALU_Mul =>
101 -- Identity element for *
102 ALU_Acc := 1;
103 when ALU_Div =>
104 -- / needs at least 1 argument
105 pragma Assert(P /= 0, "/ needs at least 1 argument");
106 CarP := Get_Car(AMem(P));
107 P := Get_Cdr(AMem(P));
108
109 -- (/ x) is 1 / x; (/ x y ...) is equivalent to x / y /
110 -- ... ; we don't support floats, so 1 / x should always
111 -- yield 0.
112 if (P = 0) then
113 ALU_Acc := 1 / Get_Fixnum(AMem(CarP));
114 else
115 ALU_Acc := Get_Fixnum(AMem(CarP));
116 end if;
117 end case;
118
119 -- Loop through the arg list and accumulate.
120 while P /= 0 loop
121 -- Get car and accumulate it
122 CarP := Get_Car(AMem(P));
123 pragma Assert(AMem(CarP).T = Fixnum,
124 "Expected a number.");
125 case Func is
126 when ALU_Add =>
127 ALU_Acc := ALU_Acc + Get_Fixnum(AMem(CarP));
128 when ALU_Sub =>
129 ALU_Acc := ALU_Acc - Get_Fixnum(AMem(CarP));
130 when ALU_Mul =>
131 ALU_Acc := ALU_Acc * Get_Fixnum(AMem(CarP));
132 when ALU_Div =>
133 pragma Assert(Get_Fixnum(AMem(CarP)) /= 0,
134 "Division by zero!");
135 ALU_Acc := ALU_Acc / Get_Fixnum(AMem(CarP));
136 end case;
137
138 -- Continue
139 P := Get_Cdr(AMem(P));
140 end loop;
141 -- Store value in a new cell and return it.
142 Alloc_Fixnum(ALU_Acc, OutP);
143 end Apply_ALU_Func;
144
145 -- Apply unary predicate.
146 procedure Apply_UPred(Pred : in UPred;
147 Args : in MemPtr;
148 Env : in MemPtr;
149 OutP : out MemPtr) is
150 P : MemPtr := Args;
151 ArgP : MemPtr;
152 begin
153 -- General form: (pred val) where pred is one of pair?, boolean?,
154 -- number?, symbol?, null? or list?. Read below for
155 -- particularities.
156
157 -- Argument sanity checking
158 pragma Assert(P /= 0, "Function requires 1 argument.");
159 ArgP := Get_Car(AMem(P));
160 P := Get_Cdr(AMem(P));
161 pragma Assert(P = 0, "Function requires 1 argument.");
162
163 -- What predicate op are we applying?
164 case Pred is
165 when UPred_Pair =>
166 -- (pair? '()) --> #f
167 -- (pair? anything-else) --> anything-else is a cons
168 if ArgP = 0 then
169 Alloc_Bool(False, OutP);
170 else
171 Alloc_Bool(AMem(ArgP).T = Cons, OutP);
172 end if;
173 when UPred_Bool =>
174 -- (boolean? '()) --> #f
175 -- (boolean? anything-else) --> anything-else is #t or #f
176 if ArgP = 0 then
177 Alloc_Bool(False, OutP);
178 else
179 Alloc_Bool(AMem(ArgP).T = Bool, OutP);
180 end if;
181 when UPred_Num =>
182 -- (number? '()) --> #f
183 -- (number? anything-else) --> anything-else is a fixnum
184 if ArgP = 0 then
185 Alloc_Bool(False, OutP);
186 else
187 Alloc_Bool(AMem(ArgP).T = Fixnum, OutP);
188 end if;
189 when UPred_Sym =>
190 -- (symbol? '()) --> #f
191 -- (symbol? 'anything-else) --> anything else is a symbol
192 if ArgP = 0 then
193 Alloc_Bool(False, OutP);
194 else
195 Alloc_Bool(AMem(ArgP).T = Symbol, OutP);
196 end if;
197 when UPred_Nil =>
198 -- (null? '()) --> #t
199 -- (null? anything-else) --> #f
200 Alloc_Bool(ArgP = 0, OutP);
201 when UPred_List =>
202 -- (list? x) --> x is a proper-list, i.e. NIL or a form
203 -- (cons e1 .. (cons en NIL))
204
205 -- try walking through a list until NIL
206 loop
207 exit when ArgP = 0;
208 exit when AMem(ArgP).T /= Cons;
209 ArgP := Get_Cdr(AMem(ArgP));
210 end loop;
211 -- if a non-NIL is encountered anywhere in a cdr (or in the
212 -- main object), then not a list.
213 Alloc_Bool(ArgP = 0, OutP);
214 end case;
215 end Apply_UPred;
216
217 -- Apply and/or special form.
218 procedure Apply_AndOr(Cond : in AndOr;
219 Args : in MemPtr;
220 Env : in MemPtr;
221 OutP : out MemPtr) is
222 P, ArgP : MemPtr;
223 ReachedEnd : Boolean := False;
224 begin
225 -- General form: (cond e1 e2 ...) where cond is one of and or
226 -- or. Particularities:
227 --
228 -- - and evaluates until the end or the first #f encountered
229 -- - or evaluates until the end or the first non-#f encountered
230 --
231 -- More details below.
232
233 P := Args;
234 if P = 0 then
235 -- vacuous truth/falsity:
236 -- (and) --> #t
237 -- (or) --> #f
238 ReachedEnd := True;
239 Alloc_Bool(Cond = AndOr_And, ArgP);
240 end if;
241 loop
242 -- have we reached the end?
243 if P = 0 then
244 ReachedEnd := True;
245 exit;
246 end if;
247 -- eval lazily:
248 -- - and stops at the first argument evaluated to #f
249 -- - or stops at the first argument evaluated to #t
250 ArgP := Get_Car(AMem(P));
251 Eval(ArgP, Env, ArgP);
252
253 exit when Cond = AndOr_And and Boolean_Value(ArgP) = False;
254 exit when Cond = AndOr_Or and Boolean_Value(ArgP) = True;
255
256 -- continue
257 P := Get_Cdr(AMem(P));
258 end loop;
259
260 -- Returned value:
261 -- (and e1 e2 ...) returns #f or the last element
262 -- (or e1 e2 ...) returns #f or the first non-#f element
263 case Cond is
264 when AndOr_And =>
265 if ReachedEnd then
266 OutP := ArgP;
267 else
268 Alloc_Bool(False, OutP);
269 end if;
270 when AndOr_Or =>
271 if ReachedEnd then
272 Alloc_Bool(False, OutP);
273 else
274 OutP := ArgP;
275 end if;
276 end case;
277 end Apply_AndOr;
278
279 -- Apply quote.
280 procedure Apply_QuoteB(Args : in MemPtr; OutP : out MemPtr) is
281 begin
282 -- General form:
283 --
284 -- (quote '()) --> ()
285 -- (quote expr) --> expr
286
287 OutP := (if Args = 0 then 0 else Get_Car(AMem(Args)));
288 end Apply_QuoteB;
289
290 -- Apply eval.
291 procedure Apply_EvalB(Args, Env : in MemPtr; OutP : out MemPtr) is
292 Arg : MemPtr;
293 begin
294 -- General form: (eval expr env), where expr is any S-expression
295 -- and env is an optional environment (currently unimplemented).
296
297 -- XXX: Need to do eval environments.
298 pragma Assert(Args /= 0, "Eval needs at least 1 argument.");
299 Arg := Get_Car(AMem(Args));
300 -- Just call eval on arg
301 Eval(Arg, Env, OutP);
302 end Apply_EvalB;
303
304 -- Apply if.
305 procedure Apply_IfB(Args, Env : in MemPtr; OutP : out MemPtr) is
306 P : MemPtr := Args;
307 PredP : MemPtr;
308 PredVal : Boolean;
309 begin
310 -- General form: (if pred a b) where pred, a and b are optional
311 -- S-expressions. The evaluation rules are:
312 --
313 -- - (if) --> ()
314 -- - (if pred) --> pred is evaluated and () is returned
315 -- - (if pred a) --> pred is evaluated
316 -- . if pred evals to #t, then a is evaluated and returned
317 -- . otherwise, () is returned
318 -- - (if pred a b) --> pred is evaluated
319 -- . if pred evals to #t, then a is evaluated and returned
320 -- . otherwise, b is evaluated and returned
321
322 -- no args: (if) --> ()
323 if P = 0 then
324 OutP := 0;
325 return;
326 end if;
327
328 -- get predicate, evaluate it and determine its boolean value
329 -- (implicitly true for non-booleans)
330 PredP := Get_Car(AMem(P));
331 Eval(PredP, Env, PredP);
332 PredVal := Boolean_Value(PredP);
333
334 -- look for branches: P points to () or (a) or (a b)
335 P := Get_Cdr(AMem(P));
336
337 -- select branch: if pred evaluated to #f and the user specified
338 -- (at least) the #t branch, then we cdr to the #f branch;
339 -- otherwise, if no branches are specified, we return.
340 if not PredVal and P /= 0 then
341 P := Get_Cdr(AMem(P));
342 elsif P = 0 then
343 OutP := 0;
344 return;
345 end if;
346 -- evaluate taken branch
347 P := Get_Car(AMem(P));
348 Eval(P, Env, OutP);
349 end Apply_IfB;
350
351 -- Apply cons.
352 procedure Apply_ConsB(Args, Env : in MemPtr; OutP : out MemPtr) is
353 P : MemPtr := Args;
354 CarP, CdrP : MemPtr;
355 begin
356 -- General form: (cons a b) where a and b are S-expressions.
357
358 pragma Assert(P /= 0, "Cons needs exactly 2 arguments.");
359 -- get car
360 CarP := Get_Car(AMem(P));
361 -- get cdr
362 P := Get_Cdr(AMem(P));
363 pragma Assert(P /= 0, "Cons needs exactly 2 arguments.");
364 CdrP := Get_Car(AMem(P));
365
366 -- Rest of P needs to be nil now.
367 P := Get_Cdr(AMem(P));
368 pragma Assert(P = 0, "Cons needs exactly 2 arguments.");
369
370 -- Cons the two
371 Alloc_Cons(CarP, CdrP, OutP);
372 end Apply_ConsB;
373
374 -- Apply car.
375 procedure Apply_CarB(Args, Env : in MemPtr; OutP : out MemPtr) is
376 P : MemPtr := Args;
377 ConsP : MemPtr;
378 begin
379 -- General form: (car x) where x is a cons.
380
381 pragma Assert(P /= 0, "car needs exactly 1 argument.");
382 -- Get x
383 ConsP := Get_Car(AMem(P));
384 pragma Assert (AMem(ConsP).T = Cons, "Expected pair.");
385 OutP := Get_Car(AMem(ConsP));
386
387 -- Rest of P needs to be nil
388 P := Get_Cdr(AMem(P));
389 pragma Assert (P = 0, "car needs exactly 1 argument.");
390 end Apply_CarB;
391
392 -- Apply cdr.
393 procedure Apply_CdrB(Args, Env : in MemPtr; OutP : out MemPtr) is
394 P : MemPtr := Args;
395 ConsP : MemPtr;
396 begin
397 -- General form: (cdr x) where x is a cons.
398
399 pragma Assert(P /= 0, "cdr needs exactly 1 argument.");
400 -- Get x
401 ConsP := Get_Car(AMem(P));
402 pragma Assert (AMem(ConsP).T = Cons, "Expected pair.");
403 OutP := Get_Cdr(AMem(ConsP));
404
405 -- Rest of P needs to be nil
406 P := Get_Cdr(AMem(P));
407 pragma Assert (P = 0, "cdr needs exactly 1 argument.");
408 end Apply_CdrB;
409
410 -- Apply list.
411 procedure Apply_ListB(Args, Env : in MemPtr; OutP : out MemPtr) is
412 begin
413 -- General form: (list e1 e2 ...) where e1 e2 ... are optional
414 -- S-expressions.
415
416 -- Applicative order evaluation is done by Apply_Func, so we just
417 -- propagate the arguments.
418 OutP := Args;
419 end Apply_ListB;
420
421 -- Apply apply.
422 procedure Apply_ApplyB(Args, Env : in MemPtr; OutP : out MemPtr) is
423 P : MemPtr := Args;
424 OpP, ArgsP, LastArgP : MemPtr;
425 begin
426 -- General form: (apply f a1 a2 ... args) where f is a function,
427 -- a1 a2 ... are S-expressions and args is a list.
428 --
429 -- The result is the same as applying f with (append (list a1 a2
430 -- ...) args) as arguments.
431
432 pragma Assert(P /= 0, "apply needs at least 1 argument.");
433
434 -- get op
435 OpP := Get_Car(AMem(P));
436
437 -- get args: this section is roughly equivalent to list* (or
438 -- cons*), i.e. (list* a1 a2 a3 ... args) --> (a1 a2 a3
439 -- ... . args), i.e. we stick args in the butt of (a1 a2 a3 ...).
440 P := Get_Cdr(AMem(P));
441 -- first, we check if we have any args at all
442 if P = 0 then goto DoApply; end if;
443 -- if so, we do a shallow (reversed) copy of the list, accumulated
444 -- in ArgsP; we put the car (the "args" above) in LastArgP and we
445 -- keep the cdr in ArgsP.
446 ArgsP := 0;
447 while P /= 0 loop
448 exit when AMem(P).T /= Cons;
449 Alloc_Cons(Get_Car(AMem(P)), ArgsP, ArgsP);
450 P := Get_Cdr(AMem(P));
451 end loop;
452 -- ArgsP has at least one element now!
453 LastArgP := Get_Car(AMem(ArgsP));
454 ArgsP := Get_Cdr(AMem(ArgsP));
455 -- now put this in the proper form
456 Rev_In_Place(ArgsP, LastArgP, P);
457
458 <<DoApply>>
459 -- Do the actual application
460 Apply_Func(OpP, P, Env, True, OutP);
461 end Apply_ApplyB;
462
463 -- Apply define.
464 procedure Apply_DefineB(Args, Env : in MemPtr; OutP : out MemPtr) is
465 P : MemPtr := Args;
466 SymP, ValP : MemPtr;
467 begin
468 -- General form: (define sym val) where sym is a symbol and val is
469 -- an optional S-expression.
470 --
471 -- XXX we need to split this into two types of defines:
472 -- symbol-defines (such as the one described here) and
473 -- lambda-defines, e.g. (define (func arg1 ...) val).
474
475 -- get sym
476 SymP := Get_Car(AMem(P));
477 pragma Assert (SymP /= 0, "Define: expected symbol for arg 1!");
478 pragma Assert (AMem(SymP).T = Symbol,
479 "Define: expected symbol for arg 1!");
480
481 -- get val: (define sym) binds sym to NIL.
482 P := Get_Cdr(AMem(P));
483 ValP := (if P = 0 then 0 else Get_Car(AMem(P)));
484
485 -- evaluate val
486 Eval(ValP, Env, ValP);
487 -- make (top-level!) binding
488 Bind_Env(SymP, ValP, Global_Env, P);
489 -- return symbol name
490 OutP := Get_Car(AMem(P));
491 end Apply_DefineB;
492
493 -- Apply set.
494 procedure Apply_SetB(Args, Env : in MemPtr; OutP : out MemPtr) is
495 P : MemPtr := Args;
496 SymP, ValP : MemPtr;
497 BindingP : MemPtr;
498 begin
499 -- General form: (set! sym val) where sym is a bound symbol and
500 -- val is an optional S-expression. set! returns the evaluated
501 -- val.
502
503 pragma Assert(P /= 0, "set! requires at least 1 argument.");
504 -- get sym
505 SymP := Get_Car(AMem(P));
506 -- and look it up in the scoped Envs
507 Lookup_Env_Or_Global(SymP, Env, BindingP);
508 -- binding must exist
509 pragma Assert(BindingP /= 0, "set! got an unbound variable.");
510
511 -- get value
512 P := Get_Cdr(AMem(P));
513 ValP := (if P = 0 then 0 else Get_Car(AMem(P)));
514 -- eval it
515 Eval(ValP, Env, ValP);
516 -- and modify the binding
517 Set_Cdr(AMem(BindingP), ValP);
518 -- return the value
519 OutP := ValP;
520 end Apply_SetB;
521
522 -- Apply numeric equality.
523 procedure Apply_EqnB(Args, Env : in MemPtr; OutP : out MemPtr) is
524 P : MemPtr := Args;
525 Fst, Other : MemPtr;
526 Result : MemPtr;
527 begin
528 -- General form: (= n1 n2 ...) where n1, n2, ... are numbers. =
529 -- expects at least two numbers as parameters.
530
531 pragma Assert(P /= 0, "= requires at least 2 arguments");
532 -- get first number
533 Fst := Get_Car(AMem(P));
534 pragma Assert(AMem(Fst).T = Fixnum, "Expected numeric arguments.");
535 -- move on to rest
536 P := Get_Cdr(AMem(P));
537 pragma Assert(P /= 0, "= requires at least 2 arguments");
538
539 -- allocate result: assume all numbers are equal until found
540 -- otherwise.
541 Alloc_Bool(True, Result);
542 -- loop through the other numbers
543 while P /= 0 loop
544 -- get other
545 Other := Get_Car(AMem(P));
546 pragma Assert(AMem(Other).T = Fixnum, "Expected numeric arguments.");
547 -- check equality: we assume two's complement representation
548 if AMem(Fst).Data /= AMem(Other).Data then
549 Set_Bool(AMem(Result), False);
550 end if;
551 -- move on to next element of the arg list
552 P := Get_Cdr(AMem(P));
553 end loop;
554 -- store result
555 OutP := Result;
556 end Apply_EqnB;
557
558 -- Apply pointer equality.
559 procedure Apply_EqB(Args, Env : in MemPtr; OutP : out MemPtr) is
560 P : MemPtr := Args;
561 P1, P2 : MemPtr;
562 begin
563 -- General form: (eq? x y) where x and y are S-expressions.
564
565 -- get x
566 pragma Assert(P /= 0, "eq? requires 2 arguments.");
567 P1 := Get_Car(AMem(P));
568 P := Get_Cdr(AMem(P));
569
570 -- get y
571 pragma Assert(P /= 0, "eq? requires 2 arguments.");
572 P2 := Get_Car(AMem(P));
573 P := Get_Cdr(AMem(P));
574 pragma Assert(P = 0, "eq? requires 2 arguments.");
575
576 -- compare x and y. XXX this is a hack, but eq? guarantees that
577 -- matching boolean values match, e.g. (eq? #f #f) --> #t. As an
578 -- alternative, we could reserve two special cells for #f and #t,
579 -- or give up the schemism altogether and use nil and everything
580 -- else as booleans.
581 --
582 -- (eq? '() '()) --> #t
583 -- (eq? 1 1) --> may be #f if the two instances of 1 have
584 -- different memory locations.
585 if P1 /= 0 and P2 /= 0 then
586 if AMem(P1).T = Bool and AMem(P2).T = Bool then
587 Alloc_Bool(AMem(P1).Data = AMem(P2).Data, OutP);
588 else
589 Alloc_Bool(P1 = P2, OutP);
590 end if;
591 else
592 Alloc_Bool(P1 = P2, OutP);
593 end if;
594 end Apply_EqB;
595
596 -- Apply value-wise equality.
597 procedure Apply_EqvB(Args, Env : in MemPtr; OutP : out MemPtr) is
598 P : MemPtr := Args;
599 Val1, Val2 : MemPtr;
600 Result : Boolean;
601 begin
602 -- General form: (eqv? x y) where x and y are
603 -- S-expressions. Unlike eq?, eqv? compares the data found in the
604 -- cells pointed to by x and y, with the exception of NIL
605 -- pointers, which are compared pointer-wise.
606
607 -- get x
608 pragma Assert(P /= 0, "eqv? requires 2 arguments.");
609 Val1 := Get_Car(AMem(P));
610 P := Get_Cdr(AMem(P));
611
612 -- get y
613 pragma Assert(P /= 0, "eqv? requires 2 arguments.");
614 Val2 := Get_Car(AMem(P));
615 P := Get_Cdr(AMem(P));
616 pragma Assert(P = 0, "eqv? requires 2 arguments.");
617
618 -- (eqv? '() y) --> (null? y)
619 -- (eqv? x y) (where x is non-NIL) --> values are equal, e.g.
620 -- - (eqv? 1 1) --> #t
621 -- - (eqv? '(1) '(1)) --> #f (comparison between values of cons cells)
622 if Val1 = 0 then
623 Result := Val2 = 0;
624 else
625 Result := AMem(Val1).Data = AMem(Val2).Data;
626 end if;
627 -- set result
628 Alloc_Bool(Result, OutP);
629 end Apply_EqvB;
630
631 -- Apply not.
632 procedure Apply_NotB(Args, Env : in MemPtr; OutP : out MemPtr) is
633 P : MemPtr := Args;
634 Val : MemPtr;
635 begin
636 -- General form: (not x) where x is a S-expression. not is
637 -- evaluated using the following rules:
638 -- - (not #f) --> #t
639 -- - (not x) (x /= #f) --> #f
640
641 -- get argument
642 pragma Assert (P /= 0, "not requires 1 argument.");
643 Val := Get_Car(AMem(P));
644 P := Get_Cdr(AMem(P));
645 pragma Assert (P = 0, "not requires 1 argument.");
646
647 -- perform logic negation on boolean value.
648 Alloc_Bool(not Boolean_Value(Val), OutP);
649 end Apply_NotB;
650
651 -- Apply lambda.
652 procedure Apply_LambdaB(Args, Env : in MemPtr; OutP : out MemPtr) is
653 begin
654 -- General form: (lambda args e1 e2 ...) where args is a list of
655 -- formal arguments (symbols) and e1 e2 ... are optional
656 -- S-expressions that may contain references to the formal
657 -- arguments; i.e., e1 e2 ... forms a lexical scope where the
658 -- formal arguments are bound.
659 --
660 -- See Alloc_Closure for more details.
661 Alloc_Closure(Args, Env, OutP);
662 end Apply_LambdaB;
663
664 -- Apply let.
665 procedure Apply_LetB(Args, Env : in MemPtr; OutP : out MemPtr) is
666 BndsP, CodeP : MemPtr;
667 ArgsP, ValuesP, ClosureP : MemPtr;
668 begin
669 -- General form: (let bnds . code) where bnds is a list (bnd1 bnd2
670 -- ...) and code is a list (e1 e2 ...). More precisely:
671 --
672 -- - bndi is a list of the form (si vi) where si is a symbol and
673 -- vi is a mandatory S-expression.
674 -- - ek is an optional S-expression that may contain references to
675 -- si.
676 --
677 -- Lets do the following: 1. every vi is evaluated; 2. every
678 -- evaluated vi is used as a lexical binding for the
679 -- corresponding si; and 3. in the newly-created lexical scope,
680 -- ek are evaluated in the order they appear in code.
681 --
682 -- More generally, any expression of the form:
683 --
684 -- (let ((s1 v1) (s2 v2) ... (sn vn)) e1 e2 ... em)
685 --
686 -- is equivalent to:
687 --
688 -- ((lambda (s1 s2 ... sn) e1 e2 ... em) v1 v2 ... vn).
689 --
690 -- Thus this implementation: 1. collects the formal arguments
691 -- (names) in ArgsP and the effective arguments (values) in
692 -- ValuesP; 2. collects the code in CodeP; 3. creates a closure
693 -- ClosureP from the list (ArgsP . CodeP); 4. applies ClosureP on
694 -- ValuesP.
695
696 -- (let) --> ()
697 if Args = 0 then
698 -- nothing to do here
699 OutP := 0;
700 return;
701 end if;
702
703 -- get bindings and code; initialize arglist and valuelist
704 BndsP := Get_Car(AMem(Args));
705 CodeP := Get_Cdr(AMem(Args));
706 ArgsP := 0; ValuesP := 0;
707
708 -- collect formal args and effective values
709 while BndsP /= 0 loop
710 declare
711 BndP : MemPtr := Get_Car(AMem(BndsP));
712 SymP, ValP : MemPtr;
713 begin
714 pragma Assert(BndP /= 0, "Bad syntax of let spec.");
715 pragma Assert(AMem(BndP).T = Cons, "Bad syntax of let spec.");
716
717 -- get symbol and advance in BndP
718 SymP := Get_Car(AMem(BndP));
719 ValP := Get_Cdr(AMem(BndP));
720 -- XXX: this is the stricter version
721 pragma Assert (ValP /= 0, "Bad syntax of binding in let.");
722 -- get val and evaluate it
723 ValP := Get_Car(AMem(ValP));
724 Eval(ValP, Env, ValP);
725 -- add symbol to ArgsP, value to ValuesP
726 Alloc_Cons(SymP, ArgsP, ArgsP);
727 Alloc_Cons(ValP, ValuesP, ValuesP);
728 -- continue
729 BndsP := Get_Cdr(AMem(BndsP));
730 end;
731 end loop;
732
733 -- cons args to code
734 Alloc_Cons(ArgsP, CodeP, CodeP);
735 -- make closure
736 Apply_LambdaB(CodeP, Env, ClosureP);
737 -- apply closure
738 Apply_Closure(ClosureP, ValuesP, Env, OutP);
739 end Apply_LetB;
740
741 -- Apply reverse.
742 procedure Apply_ReverseB(Args, Env : in MemPtr; OutP : out MemPtr) is
743 P : MemPtr := Args;
744 List : MemPtr;
745 begin
746 -- General form: (reverse x) where x is a list.
747
748 -- get x
749 pragma Assert (P /= 0, "reverse requires 1 argument.");
750 List := Get_Car(AMem(P));
751 P := Get_Cdr(AMem(P));
752 pragma Assert (P = 0, "reverse requires 1 argument.");
753
754 -- reverse x
755 Rev_Append(0, List, OutP);
756 end Apply_ReverseB;
757
758 -- Apply append.
759 procedure Apply_AppendB(Args, Env : in MemPtr; OutP : out MemPtr) is
760 Lists : MemPtr := Args;
761 Acc : MemPtr := 0;
762 begin
763 -- General form: (append x1 x2 ...) where x1 x2 ... are lists. In
764 -- particular, the last xi may be any object, in which case the
765 -- result of append is not a proper list, e.g.
766 --
767 -- - (append '(x) '(y)) --> (x y)
768 -- - (append '(x y) 'z) --> (x y . z)
769
770 -- (append) --> ()
771 if Lists = 0 then
772 OutP := 0;
773 return;
774 end if;
775
776 -- accumulate in acc; stop when Lists has one element, so that we
777 -- don't lose the reference to the last element.
778 while Get_Cdr(AMem(Lists)) /= 0 loop
779 -- prepend in reverse to Acc
780 Rev_Append(Acc, Get_Car(AMem(Lists)), Acc);
781 -- continue
782 Lists := Get_Cdr(AMem(Lists));
783 end loop;
784
785 -- reverse Acc in place, adding the last element in Lists to the
786 -- tail.
787 Rev_In_Place(Acc, Get_Car(AMem(Lists)), Acc);
788 OutP := Acc;
789 end Apply_AppendB;
790
791 -- Apply closure.
792 procedure Apply_Closure(Op, Args, Env : in MemPtr; OutP : out MemPtr) is
793 EArgs : MemPtr := Args;
794 CArgs, CCode, CEnv : MemPtr;
795 begin
796 -- General form: (f a1 a2 ... an) where:
797 --
798 -- - f is a closure object, comprising an environment env (a list
799 -- of bindings) and a code; the code is itself made of a list of
800 -- formal parameters and a code body;
801 -- - a1, a2 ... an, are arguments, i.e. effective parameters, to
802 -- f, such that n is equal to the length of the list of formal
803 -- parameters.
804 --
805 -- The application of f on the arguments is performed by binding
806 -- each formal parameter to each corresponding argument, adding
807 -- them to env and evaluating each expression in the code body in
808 -- the (lexical) context of env.
809
810 -- Initialize CArgs, CCode, CEnv.
811 CEnv := Get_Closure_Env(AMem(Op));
812 CCode := Get_Closure_Code(AMem(Op));
813 -- Do we have an arglist and code?
814 if CCode = 0 then
815 CArgs := 0;
816 else
817 CArgs := Get_Car(AMem(CCode));
818 CCode := Get_Cdr(AMem(CCode));
819 end if;
820
821 -- ((lambda () ...) ...)
822 if CArgs = 0 then goto DoEval; end if;
823
824 -- CArgs can be a:
825 -- - symbol, e.g. ((lambda x (cdr x)) 1 2) --> (2)
826 -- - list, e.g. ((lambda (x y) (+ x y)) 1 2) --> 3
827 if AMem(CArgs).T = Symbol then
828 -- extend env with a binding to effective arglist
829 Alloc_Cons(CArgs, EArgs, CArgs);
830 Alloc_Cons(CArgs, CEnv, CEnv);
831 elsif AMem(CArgs).T = Cons then
832 -- for each argument in CArgs corresponding to an actual value
833 -- in EArgs, add a binding in CEnv.
834 while CArgs /= 0 loop
835 declare
836 ArgP, ValP, BindingP : MemPtr;
837 begin
838 -- assert: (= (length CArgs) (length EArgs))
839 pragma Assert(EArgs /= 0,
840 "Not enough arguments.");
841 -- (cons (car CArgs) (car EArgs))
842 ArgP := Get_Car(AMem(CArgs));
843 ValP := Get_Car(AMem(EArgs));
844 -- add binding to env, ignore non-symbols
845 if ArgP /= 0 then
846 if AMem(ArgP).T = Symbol then
847 Alloc_Cons(ArgP, ValP, BindingP);
848 Alloc_Cons(BindingP, CEnv, CEnv);
849 end if;
850 end if;
851 -- continue with next argument
852 CArgs := Get_Cdr(AMem(CArgs));
853 EArgs := Get_Cdr(AMem(EArgs));
854 end;
855 end loop;
856 else
857 pragma Assert(False, "Expected symbol or cons.");
858 end if;
859
860 <<DoEval>>
861 -- eval all coads
862 while CCode /= 0 loop
863 declare
864 E : MemPtr;
865 begin
866 -- get current coad
867 E := Get_Car(AMem(CCode));
868 -- eval it, put result in OutP
869 Eval(E, CEnv, OutP);
870 -- continue
871 CCode := Get_Cdr(AMem(CCode));
872 end;
873 end loop;
874 end Apply_Closure;
875
876 -- Apply a function on argument list.
877 procedure Apply_Func(Op, Args, Env : in MemPtr;
878 Meta : in Boolean;
879 OutP : out MemPtr) is
880
881 -- XXX: This should actually delimit between built-in functions
882 -- and keywords; other functions (e.g. apply) may need to use
883 -- this to provide relevant errors.
884 Applicative_OrderP : constant array(BuiltinID) of Boolean :=
885 (QuoteB | IfB | DefineB | SetB | AndB | OrB | LambdaB |
886 LetB => False,
887 others => True);
888
889 BID : BuiltinID;
890 EvaledArgs : MemPtr;
891 begin
892 pragma Assert(Op /= 0, "NIL op!");
893
894 -- Is Op a builtin?
895 if AMem(Op).T = Builtin then
896 BID := Get_Builtin(AMem(Op));
897
898 -- We want to evaluate the arguments before applying the
899 -- function if:
900 -- . the function permits it, or
901 -- . Apply_Func was not called by apply (who already evals)
902 if Applicative_OrderP(BID) and (not Meta) then
903 Eval_List(Args, Env, EvaledArgs);
904 else
905 EvaledArgs := Args;
906 end if;
907 -- What builtin Op do we evaluate?
908 case BID is
909 when AddB => Apply_ALU_Func(ALU_Add, EvaledArgs, Env, OutP);
910 when SubB => Apply_ALU_Func(ALU_Sub, EvaledArgs, Env, OutP);
911 when MulB => Apply_ALU_Func(ALU_Mul, EvaledArgs, Env, OutP);
912 when DivB => Apply_ALU_Func(ALU_Div, EvaledArgs, Env, OutP);
913 when QuoteB => Apply_QuoteB(EvaledArgs, OutP);
914 when EvalB => Apply_EvalB(EvaledArgs, Env, OutP);
915 when IfB => Apply_IfB(EvaledArgs, Env, OutP);
916 when ConsB => Apply_ConsB(EvaledArgs, Env, OutP);
917 when CarB => Apply_CarB(EvaledArgs, Env, OutP);
918 when CdrB => Apply_CdrB(EvaledArgs, Env, OutP);
919 when ListB => Apply_ListB(EvaledArgs, Env, OutP);
920 when ApplyB => Apply_ApplyB(EvaledArgs, Env, OutP);
921 when DefineB => Apply_DefineB(EvaledArgs, Env, OutP);
922 when SetB => Apply_SetB(EvaledArgs, Env, OutP);
923 when EqnB => Apply_EqnB(EvaledArgs, Env, OutP);
924 when EqB => Apply_EqB(EvaledArgs, Env, OutP);
925 when EqvB => Apply_EqvB(EvaledArgs, Env, OutP);
926 when PairPB => Apply_UPred(UPred_Pair, EvaledArgs, Env, OutP);
927 when BooleanPB => Apply_UPred(UPred_Bool, EvaledArgs, Env, OutP);
928 when NumberPB => Apply_UPred(UPred_Num, EvaledArgs, Env, OutP);
929 when SymbolPB => Apply_UPred(UPred_Sym, EvaledArgs, Env, OutP);
930 when NullPB => Apply_UPred(UPred_Nil, EvaledArgs, Env, OutP);
931 when ListPB => Apply_UPred(UPred_List, EvaledArgs, Env, OutP);
932 when AndB => Apply_AndOr(AndOr_And, EvaledArgs, Env, OutP);
933 when OrB => Apply_AndOr(AndOr_Or, EvaledArgs, Env, OutP);
934 when NotB => Apply_NotB(EvaledArgs, Env, OutP);
935 when LambdaB => Apply_LambdaB(Args, Env, OutP);
936 when LetB => Apply_LetB(Args, Env, OutP);
937 when ReverseB => Apply_ReverseB(EvaledArgs, Env, OutP);
938 when AppendB => Apply_AppendB(EvaledArgs, Env, OutP);
939 end case;
940 elsif AMem(Op).T = Closure then
941 -- We evaluate the argument list only if this is not a
942 -- meta-application (e.g. called by apply).
943 if not Meta then
944 Eval_List(Args, Env, EvaledArgs);
945 else
946 EvaledArgs := Args;
947 end if;
948 -- Apply closure.
949 Apply_Closure(Op, EvaledArgs, Env, OutP);
950 else
951 OutP := 0;
952 pragma Assert(False, "Trying to apply a non-function.");
953 end if;
954 end Apply_Func;
955
956 -- Evaluate a list element by element.
957 procedure Eval_List(List, Env : in MemPtr; OutP : out MemPtr) is
958 LP : MemPtr := List;
959 Result : MemPtr := 0;
960 Default : MemPtr := 0;
961 begin
962 -- eval elements one by one
963 while LP /= 0 loop
964 declare
965 TempP : MemPtr;
966 begin
967 -- degenerate case: cdr is neither list nor nil
968 exit when AMem(LP).T /= Cons;
969 -- eval current element in LP
970 Eval(Get_Car(AMem(LP)), Env, TempP);
971 -- cons result to Result
972 Alloc_Cons(TempP, Result, Result);
973 -- advance in LP
974 LP := Get_Cdr(AMem(LP));
975 end;
976 end loop;
977
978 -- also eval in the degenerate case
979 if LP /= 0 then
980 if AMem(LP).T /= Cons then
981 Eval(LP, Env, Default);
982 end if;
983 end if;
984
985 -- result is the reverse-in-place of our computation
986 Rev_In_Place(Result, Default, OutP);
987 end Eval_List;
988
989 -- Evaluate a given S-expression
990 procedure Eval(InP, Env : in MemPtr; OutP : out MemPtr) is
991 TempP, OpP, ArgsP : MemPtr;
992 begin
993 -- NIL.
994 if (InP = 0) then
995 OutP := 0;
996 return;
997 end if;
998
999 -- Non-NIL data.
1000 case AMem(InP).T is
1001 when Free => -- this is illegal
1002 pragma Assert(False, "Trying to eval free cell!");
1003 when Cons =>
1004 -- Eval car to get Op
1005 TempP := Get_Car(AMem(InP));
1006 Eval(TempP, Env, OpP);
1007 -- Get arglist
1008 ArgsP := Get_Cdr(AMem(InP));
1009 -- Apply op on arglist
1010 Apply_Func(OpP, ArgsP, Env, False, OutP);
1011 when Bool | Fixnum | Char | Builtin | Closure =>
1012 -- Constants are returned as they are.
1013 OutP := InP;
1014 when Symbol =>
1015 -- Lookup symbol value in Env.
1016 Lookup_Env_Or_Global(InP, Env, TempP);
1017 -- If found return it, otherwise report error.
1018 if TempP = 0 then
1019 Put("Not found: "); Dump_Cell(InP);
1020 pragma Assert(False, "No binding for symbol.");
1021 end if;
1022 OutP := Get_Cdr(AMem(TempP));
1023 end case;
1024 end Eval;
1025
1026 -- Prepend the elements of B to A, in reverse.
1027 procedure Rev_Append(A, B : in MemPtr; OutP : out MemPtr) is
1028 Acc : MemPtr := A;
1029 P : MemPtr := B;
1030 begin
1031 while P /= 0 loop
1032 exit when AMem(P).T /= Cons;
1033 Alloc_Cons(Get_Car(AMem(P)), Acc, Acc);
1034 P := Get_Cdr(AMem(P));
1035 end loop;
1036
1037 pragma Assert (P = 0, "Non-list argument to append");
1038
1039 OutP := Acc;
1040 end Rev_Append;
1041
1042 procedure Rev_In_Place(List, Default : in MemPtr; OutP : out MemPtr) is
1043 P : MemPtr := List;
1044 Result : MemPtr := Default;
1045 Temp : MemPtr;
1046 begin
1047 while P /= 0 loop
1048 Temp := Get_Cdr(AMem(P)); -- save cdr
1049 Set_Cdr(AMem(P), Result); -- put partial result in tail
1050 Result := P; -- update result
1051 P := Temp; -- get cdr
1052 end loop;
1053
1054 OutP := Result;
1055 end Rev_In_Place;
1056
1057 -- Return the actual boolean associated with a Lisp value.
1058 function Boolean_Value(P : MemPtr) return Boolean is
1059 begin
1060 -- Non-boolean values (including NIL) default to True. Boolean
1061 -- values get the value of Get_Bool;
1062 if P = 0 then
1063 return True;
1064 elsif AMem(P).T = Bool then
1065 return Get_Bool(AMem(P));
1066 else
1067 return True;
1068 end if;
1069 end Boolean_Value;
1070 end Evaler;
-
+ 546D8D1AC8F29F4CEF32DFDA953790663CE53016C8F63024BE2802CF0C60D0C9D899896ABEA4896DF637AD2FC11610F54CD7B1C89CA32E1195094416F41A5DC8
adalisp/src/evaler.ads
(0 . 0)(1 . 83)
1075 -- Basic LispM evaluator, based on the following rules:
1076 --
1077 -- - LispM constants, i.e. booleans, numbers, characters, builtins and
1078 -- closures are returned as they are.
1079 --
1080 -- - Symbols have their values looked up in the current (lexical) Env
1081 -- or, if not found, in the (dynamic) Global_Env; the first value found
1082 -- is returned; if no bindings are found, an error message is returned.
1083 --
1084 -- - Cons objects are interpreted as function applications, i.e. for any
1085 -- list L, car(L) is evaluated and applied upon cdr(L); if car(L) is
1086 -- not a closure or a builtin, then an error message is returned.
1087 --
1088 -- A large subset of this module is dedicated to the implementation of
1089 -- builtin functions and keywords. An explicit distinction between
1090 -- keywords and functions is not made at this point, i.e. the
1091 -- distinction is implicit in e.g. the way arguments are evaluated.
1092
1093 with LispM; use LispM;
1094
1095 package Evaler is
1096
1097 -- Arithmetic and logic functions
1098 type ALUFunc is (ALU_Add, ALU_Sub, ALU_Mul, ALU_Div);
1099 -- Unary predicates
1100 type UPred is (UPred_Pair, UPred_Bool, UPred_Num, UPred_Sym,
1101 UPred_Nil, UPred_List);
1102 -- And/or conditional forms
1103 type AndOr is (AndOr_And, AndOr_Or);
1104
1105 -- Application routines for builtin functions. These should be
1106 -- self-explanatory.
1107 procedure Apply_ALU_Func(Func : in ALUFunc;
1108 Args : in MemPtr;
1109 Env : in MemPtr; OutP : out MemPtr);
1110 procedure Apply_UPred(Pred : in UPred;
1111 Args : in MemPtr;
1112 Env : in MemPtr;
1113 OutP : out MemPtr);
1114 procedure Apply_AndOr(Cond : in AndOr;
1115 Args : in MemPtr;
1116 Env : in MemPtr;
1117 OutP : out MemPtr);
1118
1119 procedure Apply_QuoteB(Args : in MemPtr; OutP : out MemPtr);
1120 procedure Apply_EvalB(Args, Env : in MemPtr; OutP : out MemPtr);
1121 procedure Apply_IfB(Args, Env : in MemPtr; OutP : out MemPtr);
1122 procedure Apply_ConsB(Args, Env : in MemPtr; OutP : out MemPtr);
1123 procedure Apply_CarB(Args, Env : in MemPtr; OutP : out MemPtr);
1124 procedure Apply_CdrB(Args, Env : in MemPtr; OutP : out MemPtr);
1125 procedure Apply_ListB(Args, Env : in MemPtr; OutP : out MemPtr);
1126 procedure Apply_ApplyB(Args, Env : in MemPtr; OutP : out MemPtr);
1127 procedure Apply_DefineB(Args, Env : in MemPtr; OutP : out MemPtr);
1128 procedure Apply_SetB(Args, Env : in MemPtr; OutP : out MemPtr);
1129 procedure Apply_EqnB(Args, Env : in MemPtr; OutP : out MemPtr);
1130 procedure Apply_EqB(Args, Env : in MemPtr; OutP : out MemPtr);
1131 procedure Apply_EqvB(Args, Env : in MemPtr; OutP : out MemPtr);
1132 procedure Apply_NotB(Args, Env : in MemPtr; OutP : out MemPtr);
1133 procedure Apply_LambdaB(Args, Env : in MemPtr; OutP : out MemPtr);
1134 procedure Apply_LetB(Args, Env : in MemPtr; OutP : out MemPtr);
1135 procedure Apply_ReverseB(Args, Env : in MemPtr; OutP : out MemPtr);
1136 procedure Apply_AppendB(Args, Env : in MemPtr; OutP : out MemPtr);
1137
1138 -- Application routine for closures
1139 procedure Apply_Closure(Op, Args, Env : in MemPtr; OutP : out MemPtr);
1140
1141 -- Apply function with name identified by Op, on Args.
1142 procedure Apply_Func(Op, Args, Env : in MemPtr;
1143 Meta : in Boolean;
1144 OutP : out MemPtr);
1145
1146 -- Evaluate a list element by element.
1147 procedure Eval_List(List, Env : in MemPtr; OutP : out MemPtr);
1148
1149 -- Eval S-expression
1150 procedure Eval(InP, Env : in MemPtr; OutP : out MemPtr);
1151
1152 -- Other usefuls: reverse append, reverse in place, boolean
1153 -- value. XXX: move these somewhere else.
1154 procedure Rev_Append(A, B : in MemPtr; OutP : out MemPtr);
1155 procedure Rev_In_Place(List, Default : in MemPtr; OutP : out MemPtr);
1156 function Boolean_Value(P : MemPtr) return Boolean;
1157 end Evaler;
-
+ CB79FB7B406A1D59AB393E1ADE0CCFB11DEEBEF1398F69E3BF73B675616339F018DF6EC769C54F2C922F4EE2DAC0C0FF60F571A9793BD0EBBC8AE1BE348C0FEB
adalisp/src/lispm.adb
(0 . 0)(1 . 696)
1162 -- Lisp machine, procedures for memory manipulation (at least for the
1163 -- time being).
1164 with Ada.Text_IO;
1165
1166 package body LispM is
1167
1168 -- The initial environment requires a set of symbols and their
1169 -- bindings to builtin functions/keywords. Thus we hold these into a
1170 -- statically-allocated table and we let the Lisp run-time copy them
1171 -- in AMem at the beginning of the world.
1172
1173 -- Constant symbol name size: 10 characters should be enough for
1174 -- everyone.
1175 subtype BuiltinNameSize is Integer range 1..10;
1176 -- Symbol name-builtin association
1177 type BuiltinAssoc is record
1178 BiName : String(BuiltinNameSize);
1179 BiValue : BuiltinID;
1180 end record;
1181 -- Array of BuiltinAssoc objects
1182 type BuiltinAssocs is array (Natural range <>) of BuiltinAssoc;
1183
1184 BuiltinTable : constant BuiltinAssocs :=
1185 (0 => (BiName => "+ ", BiValue => AddB),
1186 1 => (BiName => "- ", BiValue => SubB),
1187 2 => (BiName => "* ", BiValue => MulB),
1188 3 => (BiName => "/ ", BiValue => DivB),
1189 4 => (BiName => "quote ", BiValue => QuoteB),
1190 5 => (BiName => "eval ", BiValue => EvalB),
1191 6 => (BiName => "if ", BiValue => IfB),
1192 7 => (BiName => "cons ", BiValue => ConsB),
1193 8 => (BiName => "car ", BiValue => CarB),
1194 9 => (BiName => "cdr ", BiValue => CdrB),
1195 10 => (BiName => "list ", BiValue => ListB),
1196 11 => (BiName => "apply ", BiValue => ApplyB),
1197 12 => (BiName => "define ", BiValue => DefineB),
1198 13 => (BiName => "set! ", BiValue => SetB),
1199 14 => (BiName => "= ", BiValue => EqnB),
1200 15 => (BiName => "eq? ", BiValue => EqB),
1201 16 => (BiName => "eqv? ", BiValue => EqvB),
1202 17 => (BiName => "pair? ", BiValue => PairPB),
1203 18 => (BiName => "boolean? ", BiValue => BooleanPB),
1204 19 => (BiName => "number? ", BiValue => NumberPB),
1205 20 => (BiName => "symbol? ", BiValue => SymbolPB),
1206 21 => (BiName => "null? ", BiValue => NullPB),
1207 22 => (BiName => "list? ", BiValue => ListPB),
1208 23 => (BiName => "and ", BiValue => AndB),
1209 24 => (BiName => "or ", BiValue => OrB),
1210 25 => (BiName => "not ", BiValue => NotB),
1211 26 => (BiName => "lambda ", BiValue => LambdaB),
1212 27 => (BiName => "let ", BiValue => LetB),
1213 28 => (BiName => "reverse ", BiValue => ReverseB),
1214 29 => (BiName => "append ", BiValue => AppendB));
1215
1216 -- Hack: used for maintaining a special "quote" symbol used by the
1217 -- parser.
1218 Quote_Name : constant String := "quote";
1219
1220 -- Shifting functions for MWord, used for low-level arithmetic.
1221 function Shift_Left
1222 (Value : MWord;
1223 Amount : Natural)
1224 return MWord;
1225 pragma Import(Intrinsic, Shift_Left);
1226
1227 function Shift_Right
1228 (Value : MWord;
1229 Amount : Natural)
1230 return MWord;
1231 pragma Import(Intrinsic, Shift_Right);
1232
1233 -- Getters.
1234
1235 -- Get the ID of a builtin cell
1236 function Get_Builtin(C : Cell) return BuiltinID is
1237 begin
1238 pragma Assert (C.T = Builtin, "Not a builtin cell!");
1239 -- Disclaimer: This list is hand-maintained, programmer must
1240 -- ensure that 'Get' and 'Set' sides match!
1241 return BuiltinTable(Integer(C.Data)).BiValue;
1242 end Get_Builtin;
1243
1244 -- Get the car of a cons cell
1245 function Get_Car(C : Cell) return MemPtr is
1246 begin
1247 pragma Assert (C.T = Cons or C.T = Closure,
1248 "Car: Not a cons cell!");
1249 return MemPtr(Shift_Right(C.Data, 32));
1250 end Get_Car;
1251
1252 -- Get the cdr of a cons cell
1253 function Get_Cdr(C : Cell) return MemPtr is
1254 begin
1255 pragma Assert (C.T = Cons or C.T = Closure,
1256 "Cdr: Not a cons cell!");
1257 return MemPtr(C.Data and 16#0000_0000_FFFF_FFFF#);
1258 end Get_Cdr;
1259
1260 -- Get the value of a bool cell
1261 function Get_Bool(C : Cell) return Boolean is
1262 begin
1263 pragma Assert (C.T = Bool, "Not a bool cell!");
1264 pragma Assert (C.Data = 0 or C.Data = 1,
1265 "Bool cell in undefined state!");
1266 if (C.Data = 0) then
1267 return False;
1268 else
1269 return True;
1270 end if;
1271 end Get_Bool;
1272
1273 -- Get the value of a fixnum cell
1274 function Get_Fixnum(C : Cell) return Long_Integer is
1275 Temp : Long_Integer;
1276 begin
1277 pragma Assert (C.T = Fixnum, "Not a fixnum cell!");
1278 if (C.Data and 16#8000_0000_0000_0000#) /= 0 then
1279 Temp := -(Long_Integer(not C.Data) + 1);
1280 else
1281 Temp := Long_Integer(C.Data);
1282 end if;
1283 return Temp;
1284 end Get_Fixnum;
1285
1286 -- Get the value of a char cell
1287 function Get_Char(C : Cell) return Character is
1288 begin
1289 pragma Assert (C.T = Char, "Not a char cell!");
1290 return Character'Val(C.Data);
1291 end Get_Char;
1292
1293 -- Get the string (list-of-chars) associated with a symbol cell
1294 function Get_Symbol(C : Cell) return MemPtr is
1295 begin
1296 pragma Assert (C.T = Symbol, "Not a symbol cell!");
1297 return MemPtr(C.Data);
1298 end Get_Symbol;
1299
1300 -- Get the code of a closure cell (in practice, the pair car)
1301 function Get_Closure_Code(C : Cell) return MemPtr is
1302 begin
1303 return Get_Car(C);
1304 end Get_Closure_Code;
1305
1306 -- Get the env of a closure cell (in practice, the pair cdr)
1307 function Get_Closure_Env(C : Cell) return MemPtr is
1308 begin
1309 return Get_Cdr(C);
1310 end Get_Closure_Env;
1311
1312 -- Setters.
1313
1314 -- Set the value of a builtin cell.
1315 procedure Set_Builtin(C : in out Cell; B : in BuiltinID) is
1316 Index : Integer := -1;
1317 begin
1318 pragma Assert (C.T = Builtin, "Not a builtin cell!");
1319 -- Lookup builtin in table
1320 for I in 0..(BuiltinTable'Length - 1) loop
1321 if BuiltinTable(I).BiValue = B then
1322 Index := I;
1323 exit;
1324 end if;
1325 end loop;
1326 pragma Assert (Index /= -1, "Builtin not found.");
1327
1328 C.Data := MWord(Index);
1329 end Set_Builtin;
1330
1331 -- Set the car of a cons cell.
1332 procedure Set_Car(C : in out Cell; Car : in MemPtr) is
1333 begin
1334 pragma Assert (C.T = Cons or C.T = Closure,
1335 "Not a cons cell!");
1336 C.Data := (C.Data and 16#0000_0000_FFFF_FFFF#)
1337 or Shift_Left(MWord(Car), 32);
1338 end Set_Car;
1339
1340 -- Set the cdr of a cons cell.
1341 procedure Set_Cdr(C : in out Cell; Cdr : in MemPtr) is
1342 begin
1343 pragma Assert (C.T = Cons or C.T = Closure,
1344 "Not a cons cell!");
1345 C.Data := (C.Data and 16#FFFF_FFFF_0000_0000#)
1346 or MWord(Cdr);
1347 end Set_Cdr;
1348
1349 -- Set the value of a bool cell.
1350 procedure Set_Bool(C : in out Cell; Value : in Boolean) is
1351 begin
1352 pragma Assert (C.T = Bool, "Not a bool cell!");
1353 if Value then
1354 C.Data := 1;
1355 else
1356 C.Data := 0;
1357 end if;
1358 end Set_Bool;
1359
1360 -- Set the value of a fixnum cell.
1361 procedure Set_Fixnum(C : in out Cell; Value : in Long_Integer) is
1362 begin
1363 pragma Assert (C.T = Fixnum, "Not a fixnum cell!");
1364 if Value < 0 then
1365 C.Data := not MWord(-Value) + 1;
1366 else
1367 C.Data := MWord(Value);
1368 end if;
1369 end Set_Fixnum;
1370
1371 -- Set the value of a char cell.
1372 procedure Set_Char(C : in out Cell; Value : in Character) is
1373 begin
1374 pragma Assert (C.T = Char, "Not a char cell!");
1375 C.Data := MWord(Character'Pos(Value));
1376 end Set_Char;
1377
1378 -- Set the name of a symbol cell.
1379 procedure Set_Symbol(C : in out Cell; Name : in MemPtr) is
1380 IsStr : Boolean := True;
1381 PList : MemPtr := Name;
1382 PCar : MemPtr;
1383 begin
1384 pragma Assert (C.T = Symbol, "Not a symbol cell!");
1385
1386 -- Sanity check! At this point, a string is a list-of-chars, so we
1387 -- need to check that the type of list elements matches.
1388 pragma Assert (PList /= 0, "Symbol name is empty string!");
1389 while PList /= 0 loop
1390 pragma Assert (AMem(PList).T = Cons, "Not a string cons cell!");
1391
1392 -- Get car cell and check its type
1393 PCar := Get_Car(AMem(PList));
1394 if (AMem(PCar).T /= Char) then
1395 IsStr := False;
1396 exit;
1397 end if;
1398
1399 -- Get cdr cell
1400 PList := Get_Cdr(AMem(PList));
1401 end loop;
1402 pragma Assert(IsStr, "Symbol not a string!");
1403
1404 C.Data := MWord(Name);
1405 end Set_Symbol;
1406
1407 -- Set the closure code (car)
1408 procedure Set_Closure_Code(C : in out Cell; Code : in MemPtr) is
1409 begin
1410 Set_Car(C, Code);
1411 end Set_Closure_Code;
1412
1413 -- Set the closure env (cdr)
1414 procedure Set_Closure_Env(C : in out Cell; Env : in MemPtr) is
1415 begin
1416 Set_Cdr(C, Env);
1417 end Set_Closure_Env;
1418
1419 -- Allocate new cell in Lisp machine memory.
1420 procedure Alloc_Cell(C : in Cell; P : out MemPtr) is
1421 begin
1422 -- For now we just increase the heap and add the new cell.
1423
1424 -- Increase heap size
1425 Heap_End := Heap_End + 1;
1426 -- Check that we're overwriting a free cell.
1427 pragma Assert (AMem(Heap_End).T = Free,
1428 "Alloc_Cell using a non-free cell.");
1429 -- Assign given cell value
1430 AMem(Heap_End) := C;
1431 -- Set P to point to new pointer
1432 P := Heap_End;
1433 end Alloc_Cell;
1434
1435 -- Allocate builtin cell.
1436 procedure Alloc_Builtin(B : BuiltinID; P : out MemPtr) is
1437 begin
1438 Alloc_Cell((T => Builtin, Data => 0), P);
1439 Set_Builtin(AMem(P), B);
1440 end Alloc_Builtin;
1441
1442 -- Allocate a cons cell.
1443 procedure Alloc_Cons(Car, Cdr : in MemPtr; P : out MemPtr) is
1444 begin
1445 Alloc_Cell((T => Cons, Data => 0), P);
1446 Set_Car(AMem(P), Car);
1447 Set_Cdr(AMem(P), Cdr);
1448 end Alloc_Cons;
1449
1450 -- Allocate a bool cell.
1451 procedure Alloc_Bool(Value : in Boolean; P : out MemPtr) is
1452 begin
1453 Alloc_Cell((T => Bool, Data => 0), P);
1454 Set_Bool(AMem(P), Value);
1455 end Alloc_Bool;
1456
1457 -- Allocate a fixnum cell.
1458 procedure Alloc_Fixnum(Value : in Long_Integer; P : out MemPtr) is
1459 begin
1460 Alloc_Cell((T => Fixnum, Data => 0), P);
1461 Set_Fixnum(AMem(P), Value);
1462 end Alloc_Fixnum;
1463
1464 -- Allocate a char cell.
1465 procedure Alloc_Char(Value : in Character; P : out MemPtr) is
1466 begin
1467 Alloc_Cell((T => Char, Data => 0), P);
1468 Set_Char(AMem(P), Value);
1469 end Alloc_Char;
1470
1471 -- Allocate a symbol cell.
1472 procedure Alloc_Symbol(Name : in MemPtr; P : out MemPtr) is
1473 begin
1474 Alloc_Cell((T => Symbol, Data => 0), P);
1475 Set_Symbol(AMem(P), Name);
1476 end Alloc_Symbol;
1477
1478 -- Allocate a closure cell.
1479 procedure Alloc_Closure(Code, Env : in MemPtr; P : out MemPtr) is
1480 begin
1481 Alloc_Cell((T => Closure, Data => 0), P);
1482 Set_Closure_Code(AMem(P), Code);
1483 Set_Closure_Env(AMem(P), Env);
1484 end Alloc_Closure;
1485
1486 -- Dump cell from Lisp machine memory.
1487 procedure Dump_Cell(P : in MemPtr) is
1488 use Ada.Text_IO;
1489
1490 C : Cell;
1491 begin
1492 -- Check for NIL.
1493 if (P = 0) then
1494 -- Scheme notation.
1495 Put("()");
1496 return;
1497 end if;
1498
1499 -- Otherwise our cell lies in AMem. It's either a free cell or it
1500 -- has some allocated data in it.
1501 C := AMem(P);
1502 case C.T is
1503 when Free =>
1504 Put("<free cell>");
1505 when Builtin =>
1506 -- XXX check whether the builtin is a function or a keyword.
1507 Put("<builtin func ");
1508 Dump_BuiltinID(Get_Builtin(C));
1509 Put(">");
1510 when Cons =>
1511 Dump_Cons(P);
1512 when Bool =>
1513 if C.Data = 0 then
1514 Put("#f");
1515 else
1516 Put("#t");
1517 end if;
1518 when Fixnum =>
1519 Dump_Longint(Get_Fixnum(C));
1520 when Char =>
1521 Put("#\");
1522 if Get_Char(C) = ' ' then
1523 Put("space");
1524 else
1525 Put(Get_Char(C));
1526 end if;
1527 when Symbol =>
1528 Dump_String(Get_Symbol(C));
1529 when Closure =>
1530 Put("<closure>");
1531 end case;
1532 end Dump_Cell;
1533
1534 -- Recursively dump a cons cell, doing sugary processing.
1535 procedure Dump_Cons(P : in MemPtr) is
1536 use Ada.Text_IO;
1537
1538 C : Cell;
1539 begin
1540 -- Initialization and sanity checks
1541 pragma Assert (P /= 0, "List must be non-empty.");
1542 C := AMem(P);
1543 pragma Assert (C.T = Cons,
1544 "Dump_Cons must receive pointer to a Cons cell.");
1545
1546 -- Special processing: if our cons is a list of the form (quote
1547 -- expr), print 'expr.
1548 declare
1549 CarP, CdrP, CadrP : MemPtr;
1550 begin
1551 CarP := Get_Car(C);
1552 CdrP := Get_Cdr(C);
1553 -- Car(P) = Quote_Sym?
1554 if CarP = Quote_Sym then
1555 -- Cdr(P) /= 0?
1556 if CdrP = 0 then
1557 Put("()");
1558 return;
1559 end if;
1560 -- Get Cadr(P)
1561 CadrP := Get_Car(AMem(CdrP));
1562 -- 'expr
1563 Put("'");
1564 Dump_Cell(CadrP);
1565 return;
1566 end if;
1567 end;
1568
1569 -- This cons cell may be a list, so we iterate through it as
1570 -- long as possible and recursively call ourselves.
1571 Put("(");
1572 Dump_Cell(Get_Car(C));
1573
1574 -- XXX This will fail *hard* for circular lists!
1575 while Get_Cdr(C) /= 0 loop
1576 -- Exit if cdr(C).tag /= cons.
1577 exit when (AMem(Get_Cdr(C)).T /= Cons);
1578 C := AMem(Get_Cdr(C));
1579
1580 Put(" ");
1581 Dump_Cell(Get_Car(C));
1582 end loop;
1583
1584 -- What remains should be either a NIL or some other
1585 -- value. In the latter case, print it in dotted format.
1586 if Get_Cdr(C) /= 0 then
1587 Put(" . ");
1588 Dump_Cell(Get_Cdr(C));
1589 end if;
1590 Put(")");
1591 end Dump_Cons;
1592
1593 procedure Dump_Longint(N : in Long_Integer) is
1594 use Ada.Text_IO;
1595
1596 N1, N2 : Long_Integer;
1597 Num_Digits : Integer;
1598 begin
1599 -- 0
1600 if N = 0 then
1601 Put("0");
1602 return;
1603 end if;
1604
1605 -- Check whether N is negative
1606 if N < 0 then
1607 Put('-');
1608 N1 := -N;
1609 else
1610 N1 := N;
1611 end if;
1612
1613 -- Compute the number of digits
1614 N2 := 0;
1615 Num_Digits := 0;
1616 while N1 /= 0 loop
1617 N2 := N2 * 10 + N1 rem 10;
1618 N1 := N1 / 10;
1619 Num_Digits := Num_Digits + 1;
1620 end loop;
1621 -- Same, but algorithm, but print digit by digit
1622 while Num_Digits > 0 loop
1623 N1 := N2 rem 10;
1624 N2 := N2 / 10;
1625 Put(Character'Val(N1 + Character'Pos('0')));
1626 Num_Digits := Num_Digits - 1;
1627 end loop;
1628 end Dump_Longint;
1629
1630 procedure Dump_BuiltinID(BID : in BuiltinID) is
1631 use Ada.Text_IO;
1632 begin
1633 case BID is
1634 when AddB => Put("+");
1635 when SubB => Put("-");
1636 when MulB => Put("*");
1637 when DivB => Put("/");
1638 when QuoteB => Put("quote");
1639 when EvalB => Put("eval");
1640 when IfB => Put("if");
1641 when ConsB => Put("cons");
1642 when CarB => Put("car");
1643 when CdrB => Put("cdr");
1644 when ListB => Put("list");
1645 when ApplyB => Put("apply");
1646 when DefineB => Put("define");
1647 when SetB => Put("set");
1648 when EqnB => Put("eqn");
1649 when EqB => Put("eq");
1650 when EqvB => Put("eqv");
1651 when PairPB => Put("pairp");
1652 when BooleanPB => Put("booleanp");
1653 when NumberPB => Put("numberp");
1654 when SymbolPB => Put("symbolp");
1655 when NullPB => Put("nullp");
1656 when ListPB => Put("listp");
1657 when AndB => Put("and");
1658 when OrB => Put("or");
1659 when NotB => Put("not");
1660 when LambdaB => Put("lambda");
1661 when LetB => Put("let");
1662 when ReverseB => Put("reverse");
1663 when AppendB => Put("append");
1664 end case;
1665 end Dump_BuiltinID;
1666
1667 -- Dump string represented as list of characters.
1668 procedure Dump_String(P : in MemPtr) is
1669 use Ada.Text_IO;
1670
1671 CarP, ListP : MemPtr;
1672 begin
1673 ListP := P;
1674 while ListP /= 0 loop
1675 pragma Assert(AMem(ListP).T = Cons, "Not a string-as-list!");
1676 CarP := Get_Car(AMem(ListP));
1677
1678 -- print elem.
1679 pragma Assert(AMem(CarP).T = Char, "Not a list of chars!");
1680 Put(Get_Char(AMem(CarP)));
1681
1682 -- next
1683 ListP := Get_Cdr(AMem(ListP));
1684 end loop;
1685 end Dump_String;
1686
1687 -- Init default bindings to builtin functions
1688 procedure Init_Builtin_Bindings is
1689 BuiltinP : MemPtr;
1690 SymP : MemPtr;
1691 CharP : MemPtr;
1692 NameP : MemPtr;
1693 begin
1694 -- Allocate symbol-value pair for each builtin, and add it to the
1695 -- front of Symbol_Table list.
1696 for I in 0..(BuiltinTable'Length - 1) loop
1697 -- allocate builtin
1698 Alloc_Builtin(BuiltinTable(I).BiValue, BuiltinP);
1699 -- allocate name
1700 NameP := 0;
1701 for K in reverse BuiltinTable(I).BiName'Range loop
1702 -- skip spaces
1703 if BuiltinTable(I).BiName(K) /= ' ' then
1704 Alloc_Char(BuiltinTable(I).BiName(K), CharP);
1705 Alloc_Cons(CharP, NameP, NameP);
1706 end if;
1707 end loop;
1708 pragma Assert(NameP /= 0, "Name is empty!");
1709 Alloc_Symbol(NameP, SymP); -- create symbol
1710 Alloc_Cons(SymP, Sym_Table, Sym_Table); -- intern
1711 Bind_Env(SymP, BuiltinP, Global_Env, SymP); -- bind in global namespace
1712 end loop;
1713
1714 -- XXX: Set Quote_Sym to be used by parser routine to convert the
1715 -- quote token to a proper S-expression. This is quite a
1716 -- hack, quote symbol could be represented as its own constant by
1717 -- lispm.
1718 NameP := 0;
1719 for K in reverse Quote_Name'Range loop
1720 Alloc_Char(Quote_Name(K), CharP);
1721 Alloc_Cons(CharP, NameP, NameP);
1722 end loop;
1723
1724 Lookup_Symbol(NameP, Quote_Sym);
1725
1726 -- Use these for debugging.
1727
1728 -- Dump_Cell(Sym_Table);
1729 -- Dump_Cell(Global_Env);
1730 end Init_Builtin_Bindings;
1731
1732 function Name_EqualP(Sym1, Sym2 : MemPtr) return Boolean is
1733 TempStr1, TempStr2 : MemPtr;
1734 P1, P2 : MemPtr;
1735 C1, C2 : Character;
1736 Same : Boolean := True;
1737 begin
1738 TempStr1 := Sym1;
1739 TempStr2 := Sym2;
1740 -- Compare strings character by character: iterate while any of
1741 -- the strings are not NIL.
1742 while TempStr1 /= 0 or TempStr2 /= 0 loop
1743 -- If any of them is NIL, then stop and return false.
1744 if TempStr1 = 0 or TempStr2 = 0 then
1745 Same := False;
1746 exit;
1747 end if;
1748 -- Otherwise, do the cars match?
1749 P1 := Get_Car(AMem(TempStr1)); C1 := Get_Char(AMem(P1));
1750 P2 := Get_Car(AMem(TempStr2)); C2 := Get_Char(AMem(P2));
1751 if C1 /= C2 then
1752 Same := False;
1753 exit;
1754 end if;
1755 -- If they do, check the rest.
1756 TempStr1 := Get_Cdr(AMem(TempStr1));
1757 TempStr2 := Get_Cdr(AMem(TempStr2));
1758 end loop;
1759
1760 return Same;
1761 end Name_EqualP;
1762
1763 -- Lookup Sym_Table for symbol whose name field is equal to Name.
1764 procedure Lookup_Symbol(Name : in MemPtr; Sym : out MemPtr) is
1765 ListP : MemPtr := Sym_Table;
1766 begin
1767 -- Assume we haven't found a value
1768 Sym := 0;
1769
1770 -- Iterate through Sym_Table
1771 while ListP /= 0 loop
1772 declare
1773 CurrSym : MemPtr := Get_Car(AMem(ListP));
1774 CurrName : MemPtr;
1775 begin
1776 pragma Assert(CurrSym /= 0, "Sym_Table contains a NIL symbol!");
1777 pragma Assert(AMem(CurrSym).T = Symbol,
1778 "Sym_Table contains a non-symbol!");
1779 -- Compare the given symbol name with the current alist value.
1780 CurrName := Get_Symbol(AMem(CurrSym));
1781 -- Found?
1782 if Name_EqualP(Name, CurrName) then
1783 Sym := CurrSym;
1784 exit;
1785 end if;
1786 -- Otherwise keep looking
1787 ListP := Get_Cdr(AMem(ListP));
1788 end;
1789 end loop;
1790 end Lookup_Symbol;
1791
1792 -- Lookup Name in Sym_Table; if non-existent, add a new (Name . NIL)
1793 -- pair to the table and set NameVal to it.
1794 procedure Lookup_Or_Create_Symbol(Name : in MemPtr; Sym: out MemPtr) is
1795 TempSym : MemPtr;
1796 begin
1797 -- Lookup for Name
1798 Lookup_Symbol(Name, TempSym);
1799 -- If not found, intern Name
1800 if TempSym = 0 then
1801 Alloc_Symbol(Name, TempSym);
1802 Alloc_Cons(TempSym, Sym_Table, Sym_Table);
1803 end if;
1804 -- Return symbol
1805 Sym := TempSym;
1806 end Lookup_Or_Create_Symbol;
1807
1808 -- Lookup Sym in Env set Binding to the Sym-Value pair if found.
1809 procedure Lookup_Env(Sym, Env : in MemPtr; Binding : out MemPtr) is
1810 EnvP : MemPtr := Env;
1811 begin
1812 -- NIL by default
1813 Binding := 0;
1814
1815 while EnvP /= 0 loop
1816 declare
1817 CurrBinding : MemPtr := Get_Car(AMem(EnvP));
1818 CurrSym : MemPtr;
1819 begin
1820 pragma Assert (CurrBinding /= 0, "NIL binding in Env!");
1821 -- Get symbol of current binding
1822 CurrSym := Get_Car(AMem(CurrBinding));
1823 pragma Assert(AMem(CurrSym).T = Symbol, "Not a symbol!");
1824 -- Compare symbols pointer-wise
1825 if Sym = CurrSym then
1826 Binding := CurrBinding;
1827 exit;
1828 end if;
1829 EnvP := Get_Cdr(AMem(EnvP));
1830 end;
1831 end loop;
1832 end Lookup_Env;
1833
1834 -- Lookup value of Sym in Env or Global_Env
1835 procedure Lookup_Env_Or_Global(Sym, Env : in MemPtr;
1836 Binding : out MemPtr) is
1837 TempP : MemPtr;
1838 begin
1839 Lookup_Env(Sym, Env, TempP);
1840 if TempP = 0 then
1841 Lookup_Env(Sym, Global_Env, Binding);
1842 else
1843 Binding := TempP;
1844 end if;
1845 end Lookup_Env_Or_Global;
1846
1847 -- Add Sym-Value binding in Env and set Binding to the new pair.
1848 procedure Bind_Env(Sym, Value : in MemPtr;
1849 Env : in out MemPtr; Binding : out MemPtr) is
1850 TempP : MemPtr;
1851 begin
1852 Alloc_Cons(Sym, Value, TempP); -- create pair
1853 Alloc_Cons(TempP, Env, Env); -- cons pair to env
1854
1855 Binding := TempP; -- return pair.
1856 end Bind_Env;
1857 end LispM;
-
+ 0FC0C9657956634910EDC6DC4ABE8C5F9743F9C541491D3C1800CD9F9C05B3BF081190DD80C90ABBA91E9358D43CF40F1B7C20F645FFEBAF459683E711ABD782
adalisp/src/lispm.ads
(0 . 0)(1 . 157)
1862 -- Basic lisp machine memory and data representation. The basic memory
1863 -- unit of lisp machines is a cell of the form [ tag | data ]. Lisp
1864 -- memory is an array of such cells, with cell index 0 being reserved
1865 -- for the special value NIL.
1866 package LispM is
1867 -- 8MCells should be enough for everyone
1868 Mem_Size : constant := 2**23;
1869
1870 -- Machine words
1871 type MWord is mod 2 ** 64;
1872 for MWord'Size use 64;
1873
1874 -- Cell tags.
1875 type Tag is (Free, Builtin, Cons, Bool, Fixnum, Char, Symbol, Closure);
1876 type MemPtr is range 0 .. Mem_Size;
1877
1878 -- Built-in functions are tied in to a conceptual arithmetic-logic
1879 -- unit that provides the building blocks for evaluation.
1880 type BuiltinID is (AddB, SubB, MulB, DivB, QuoteB, EvalB, IfB,
1881 ConsB, CarB, CdrB, ListB, ApplyB, DefineB, SetB,
1882 EqnB, EqB, EqvB, PairPB, BooleanPB, NumberPB, SymbolPB,
1883 NullPB, ListPB, AndB, OrB, NotB, LambdaB, LetB,
1884 ReverseB, AppendB);
1885
1886 -- Cell data type. The first part of any cell is a tag. The second
1887 -- part is a tag-dependent machine word.
1888 --
1889 -- Machine words are defined by tag, as follows:
1890 --
1891 -- [ free | 0 ]
1892 --
1893 -- [ builtin | bid ] where bid is a number corresponding uniquely to
1894 -- a BuiltinID.
1895 --
1896 -- [ cons | car, cdr ] where car and cdr are each half of an MWord.
1897 --
1898 -- [ bool | b ] where b is a truth value (0 is false, 1 is true). XXX
1899 -- bool values should be hardcoded symbols (or something similar).
1900 --
1901 -- [ fixnum | n ] where n is a signed integer of MWord size / 2, the
1902 -- first bit being a sign bit.
1903 --
1904 -- [ char | c ] where c is the ASCII code of a character.
1905 --
1906 -- [ symbol | ptr ] where ptr points to a list of characters uniquely
1907 -- determining the symbol's name.
1908 --
1909 -- [ closure | code, env ] where code points to a list of the form
1910 -- (args e1 e2 ... en) (where args is a list of symbols) and env
1911 -- points to a symbol-value alist.
1912 type Cell is record
1913 T : Tag;
1914 Data : MWord;
1915 end record;
1916
1917 -- This puts it all together.
1918 type Mem is array (MemPtr range 1 .. Mem_Size) of Cell;
1919
1920 -- Pointer to heap end. This is incremented on memory
1921 -- allocations. Don't worry about deallocations for now, since we
1922 -- don't have a GC (yet).
1923 Heap_End : MemPtr := 0;
1924
1925 -- Pointer to interned symbol list.
1926 Sym_Table : MemPtr := 0;
1927 -- Pointer to interned symbol representing the "quote" keyword. This
1928 -- is used by the parser to transform ' tokens into (quote ...).
1929 Quote_Sym : MemPtr := 0;
1930
1931 -- Pointer to environment: the environment is a list of symbol-value
1932 -- associations; a symbol may have more than one associations at a
1933 -- given point in time, in which case the most recent association
1934 -- will be considered.
1935 Global_Env : MemPtr := 0;
1936
1937 -- A statically-allocated memory.
1938 AMem : Mem := (others => (T => Free, Data => 0));
1939
1940 -- Cell manipulation primitives.
1941 function Get_Builtin(C : Cell) return BuiltinID;
1942 function Get_Car(C : Cell) return MemPtr;
1943 function Get_Cdr(C : Cell) return MemPtr;
1944 function Get_Bool(C : Cell) return Boolean;
1945 function Get_Fixnum(C : Cell) return Long_Integer;
1946 function Get_Char(C : Cell) return Character;
1947 function Get_Symbol(C : Cell) return MemPtr;
1948 function Get_Closure_Code(C : Cell) return MemPtr;
1949 function Get_Closure_Env(C : Cell) return MemPtr;
1950 procedure Set_Builtin(C : in out Cell; B : in BuiltinID);
1951 procedure Set_Car(C : in out Cell; Car : in MemPtr);
1952 procedure Set_Cdr(C : in out Cell; Cdr : in MemPtr);
1953 procedure Set_Bool(C : in out Cell; Value : in Boolean);
1954 procedure Set_Fixnum(C : in out Cell; Value : in Long_Integer);
1955 procedure Set_Char(C : in out Cell; Value : in Character);
1956 procedure Set_Symbol(C : in out Cell; Name : in MemPtr);
1957 procedure Set_Closure_Code(C : in out Cell; Code : in MemPtr);
1958 procedure Set_Closure_Env(C : in out Cell; Env : in MemPtr);
1959
1960 -- Memory management primitives.
1961
1962 -- Allocate cell in AMem.
1963 procedure Alloc_Cell(C : in Cell; P : out MemPtr);
1964 -- Higher-level allocation primitives
1965 procedure Alloc_Builtin(B : BuiltinID; P : out MemPtr);
1966 procedure Alloc_Cons(Car, Cdr : in MemPtr; P : out MemPtr);
1967 procedure Alloc_Bool(Value : in Boolean; P : out MemPtr);
1968 procedure Alloc_Fixnum(Value : in Long_Integer; P : out MemPtr);
1969 procedure Alloc_Char(Value : in Character; P : out MemPtr);
1970 procedure Alloc_Symbol(Name : in MemPtr; P : out MemPtr);
1971 procedure Alloc_Closure(Code, Env : in MemPtr; P : out MemPtr);
1972
1973 -- I/O: output primitives. XXX these should be placed in a separate
1974 -- module.
1975
1976 -- Dump cell to standard output.
1977 procedure Dump_Cell(P : in MemPtr);
1978
1979 -- Recursively dump a cons cell, doing sugary processing.
1980 procedure Dump_Cons(P : in MemPtr);
1981
1982 -- Dump a long integer
1983 procedure Dump_Longint(N : in Long_Integer);
1984
1985 -- Dump the name of a builtin id
1986 procedure Dump_BuiltinID(BID : in BuiltinID);
1987
1988 -- Dump a sequence of chars represented as a list.
1989 procedure Dump_String(P : in MemPtr);
1990
1991 -- Init symbol table to a list of known symbols and add their
1992 -- bindings to builtins to the global environment.
1993 procedure Init_Builtin_Bindings;
1994
1995 -- Check whether two symbol names are equal.
1996 function Name_EqualP(Sym1, Sym2 : MemPtr) return Boolean;
1997
1998 -- Lookup symbol in symbol table. Return a pointer to a the unique
1999 -- symbol object representing it if found, NIL otherwise.
2000 procedure Lookup_Symbol(Name : in MemPtr; Sym : out MemPtr);
2001
2002 -- Similar to Lookup_Symbol, only if the name does not exist, we
2003 -- create and add a new symbol object to the symbol table, and we
2004 -- return it.
2005 procedure Lookup_Or_Create_Symbol(Name : in MemPtr;
2006 Sym : out MemPtr);
2007
2008 -- Lookup a binding for Sym in Env. Returns a symbol-value pair if it
2009 -- exists, NIL otherwise.
2010 procedure Lookup_Env(Sym, Env : in MemPtr; Binding : out MemPtr);
2011 -- Similar to Lookup_Env, only also try Global_Env
2012 procedure Lookup_Env_Or_Global(Sym, Env : in MemPtr;
2013 Binding : out MemPtr);
2014
2015 -- Add a Sym-Value binding in Env. Returns the new binding.
2016 procedure Bind_Env(Sym, Value : in MemPtr;
2017 Env : in out MemPtr; Binding : out MemPtr);
2018 end LispM;
-
+ D343C9D00E533B72E6B07F6E9849BFB796DF42AE0E0D376EF7B459C261124311AAB7402EA6E9608BB84DD2037AB837A6C06F9935D371A6D7EFF75A619C054670
adalisp/src/parser.adb
(0 . 0)(1 . 291)
2023 -- S-expression parser implementation.
2024 with Ada.Text_IO; use Ada.Text_IO;
2025
2026 package body Parser is
2027 -- Predicates on input characters
2028 WhitespaceP : constant array (Character) of Boolean :=
2029 (' ' | ASCII.Nul | ASCII.HT | ASCII.CR | ASCII.LF => True, others => False);
2030 DigitP : constant array (Character) of Boolean :=
2031 ('0' .. '9' => True, others => False);
2032
2033 -- Reserved characters, although '.' and '#' can technically speaking
2034 -- be part of symbol names.
2035 ReservedP : constant array (Character) of Boolean :=
2036 ('(' | ')' | '#' | '.' | ''' => True, others => False);
2037
2038 C : Character := ' ';
2039 I : Long_Integer;
2040
2041 -- Given a string, check if all its characters are digits. If so,
2042 -- accumulate them in I.
2043 procedure Parse_Integer(Str : in MemPtr;
2044 Success : out Boolean;
2045 I : out Long_Integer) is
2046 P : MemPtr := Str;
2047 PC : MemPtr;
2048 C : Character;
2049 Negative : Boolean := False;
2050 Result : Long_Integer;
2051 begin
2052 Result := 0;
2053 Success := True;
2054
2055 pragma Assert (P /= 0, "Parse_Integer received a NIL string!");
2056
2057 -- Check for leading +/- signs first
2058 PC := Get_Car(AMem(P));
2059 C := Get_Char(AMem(PC));
2060 if C = '-' then
2061 Negative := True;
2062 end if;
2063 if C = '-' or C = '+' then
2064 P := Get_Cdr(AMem(P));
2065 -- If we don't have other characters after + or -, then this is
2066 -- not a number.
2067 if P = 0 then
2068 Success := False;
2069 return;
2070 end if;
2071 end if;
2072
2073 while P /= 0 loop
2074 -- Check list and its car.
2075 PC := Get_Car(AMem(P));
2076 C := Get_Char(AMem(PC));
2077
2078 -- Do we have a non-digit?
2079 if not DigitP(C) then
2080 Success := False;
2081 exit;
2082 end if;
2083
2084 -- If we're still in the all-digits game, gather them, hoping
2085 -- we get a number.
2086 Result := Result * 10 + (Character'Pos(C) - Character'Pos('0'));
2087
2088 -- Move on.
2089 P := Get_Cdr(AMem(P));
2090 end loop;
2091
2092 if Negative then
2093 Result := -Result;
2094 end if;
2095
2096 -- Set the output value if and only if we succeeded.
2097 if Success then
2098 I := Result;
2099 end if;
2100 end Parse_Integer;
2101
2102 procedure Eat_Whitespace is
2103 begin
2104 while WhitespaceP(C) loop
2105 Get(C);
2106 end loop;
2107 end Eat_Whitespace;
2108
2109 -- Parse a list of characters that may be a symbol or an integer.
2110 procedure Parse_Atom(P : out MemPtr) is
2111 CharP, TempP : MemPtr;
2112 ListP : MemPtr := 0;
2113 ListTailP : MemPtr := 0;
2114 begin
2115 pragma Assert (not ReservedP(C),
2116 "Parse_Atom received a reserved character!");
2117
2118 loop
2119 -- Get a new char cell
2120 Alloc_Char(C, CharP);
2121 -- Save old list tail
2122 TempP := ListTailP;
2123 -- Cons cell to be appended to the list
2124 Alloc_Cons(CharP, 0, ListTailP);
2125
2126 -- Does the old list tail point to a cons cell? If so, set the
2127 -- old cdr to the new list tail, otherwise set the list
2128 -- pointer to the tail.
2129 if TempP /= 0 then
2130 Set_Cdr(AMem(TempP), ListTailP);
2131 else
2132 ListP := ListTailP;
2133 end if;
2134
2135 -- Get a new character and verify the exit condition
2136 Get(C);
2137 exit when WhitespaceP(C);
2138 exit when C = '(' or C = ')';
2139 end loop;
2140 -- Assign output parameter to our list.
2141 P := ListP;
2142 end Parse_Atom;
2143
2144 -- Parse hash-prepended expression.
2145 procedure Parse_Hash(P : out MemPtr; TID : out TokenID) is
2146 begin
2147 pragma Assert (C = '#',
2148 "Parse_Hash does not begin with a hash.");
2149
2150 -- We support the following hash-prepended expressions:
2151 --
2152 -- . booleans (#t or #f)
2153 -- . characters (e.g. #\a, #\b, ...)
2154
2155 Get(C);
2156
2157 if (C = 't') then -- true
2158 Alloc_Bool(True, P);
2159 TID := Bool_Token;
2160 elsif (C = 'f') then -- false
2161 Alloc_Bool(False, P);
2162 TID := Bool_Token;
2163 elsif (C = '\') then -- char
2164 -- XXX should do more elaborate parsing here, e.g. #\space
2165 -- etc.
2166 Get(C);
2167 Alloc_Char(C, P);
2168 TID := Char_Token;
2169 else -- unknown
2170 pragma Assert (False, "Unknown hash expression.");
2171 end if;
2172
2173 -- Emulate a space for future calls of Parse
2174 C := ' ';
2175 end Parse_Hash;
2176
2177 -- Parse cons objects, i.e. lists and pairs.
2178 procedure Parse_Cons(P : out MemPtr) is
2179 ListP : MemPtr := 0;
2180 ListTailP : MemPtr := 0;
2181 TID : TokenID;
2182 begin
2183 pragma Assert (C = '(', "Parse_Cons should receive an open paren.");
2184
2185 -- Emulate a space for the first call to Parse
2186 C := ' ';
2187
2188 -- Iterate through the list elements and add them to the list.
2189 loop
2190 declare
2191 ElemP, TempP : MemPtr;
2192 begin
2193 -- Parse current element
2194 Parse(ElemP, TID);
2195
2196 -- Exit conditions
2197 exit when TID = ListE_Token; -- list end
2198 exit when TID = ListP_Token; -- pair marker
2199
2200 -- Save old list tail
2201 TempP := ListTailP;
2202 -- Add new element to the list: if the TempP is NIL, then we
2203 -- have a fresh list that we can populate with the new
2204 -- element.
2205 Alloc_Cons(ElemP, 0, ListTailP);
2206 if TempP = 0 then
2207 ListP := ListTailP;
2208 else
2209 Set_Cdr(AMem(TempP), ListTailP);
2210 end if;
2211 end;
2212 end loop;
2213
2214 -- If we received a pair marker, then we have one more element to
2215 -- parse.
2216 if TID = ListP_Token then
2217 declare
2218 ElemP : MemPtr;
2219 begin
2220 pragma Assert (ListTailP /= 0, "Syntax error parsing pair.");
2221 -- Emulate space
2222 C := ' ';
2223 -- Parse element
2224 Parse(ElemP, TID);
2225
2226 pragma Assert(TID = Bool_Token or TID = Num_Token or
2227 TID = List_Token or TID = Char_Token or
2228 TID = Symbol_Token,
2229 "Syntax error parsing pair.");
2230 -- Point cdr of list tail to element
2231 Set_Cdr(AMem(ListTailP), ElemP);
2232 end;
2233 elsif TID /= ListE_Token then
2234 Put_Line("Impossible to get here!");
2235 P := 0;
2236 return;
2237 end if;
2238
2239 -- Set the output and emulate a space for whatever comes next.
2240 P := ListP;
2241 C := ' ';
2242 end Parse_Cons;
2243
2244 -- Parse quoted S-expression.
2245 procedure Parse_Quoted(P : out MemPtr; TID : out TokenID) is
2246 ExprP : MemPtr;
2247 begin
2248 pragma Assert (C = ''', "Parse_Quoted not given a quote");
2249
2250 -- Emulate a space and parse whatever comes after the quote.
2251 C := ' ';
2252 Parse(ExprP, TID);
2253
2254 -- If the result of Parse is an atomic constant, we return it as
2255 -- it is. Otherwise we wrap whatever expr we get in a quote,
2256 -- i.e. (quote expr).
2257 case TID is
2258 when Bool_Token | Num_Token | Char_Token =>
2259 P := ExprP;
2260 when others =>
2261 -- (expr)
2262 Alloc_Cons(ExprP, 0, ExprP);
2263 -- (quote expr)
2264 Alloc_Cons(Quote_Sym, ExprP, ExprP);
2265 -- Assign output
2266 P := ExprP;
2267 TID := Quoted_Token;
2268 end case;
2269 end Parse_Quoted;
2270
2271 -- Parse any S-expression
2272 procedure Parse(P : out MemPtr; TID : out TokenID) is
2273 TempTID : TokenID := Error_Token;
2274 AtomP : MemPtr;
2275 TempP1, TempP2, TempP3 : MemPtr := 0;
2276 Is_Number : Boolean;
2277 begin
2278 P := 0;
2279 TID := Error_Token;
2280
2281 Eat_Whitespace;
2282
2283 -- Not (, ), #, . or '
2284 if not ReservedP(C) then -- atom
2285 -- Read atom from stdin
2286 Parse_Atom(AtomP);
2287
2288 -- Try to parse a number; if we succeed, then return it, else
2289 -- return the atom as an interned symbol.
2290 Parse_Integer(AtomP, Is_Number, I);
2291 if Is_Number then
2292 Alloc_Fixnum(I, P);
2293 TID := Num_Token;
2294 else
2295 -- Alloc symbol cell
2296 Lookup_Or_Create_Symbol(AtomP, P);
2297 TID := Symbol_Token;
2298 end if;
2299 elsif C = '#' then -- hash token
2300 Parse_Hash(P, TID);
2301 elsif C = '(' then -- list/pair
2302 Parse_Cons(P);
2303 -- Instantiate TID
2304 TID := List_Token;
2305 elsif C = ')' then -- list/pair end
2306 TID := ListE_Token;
2307 elsif C = '.' then -- pair marker
2308 TID := ListP_Token;
2309 elsif C = ''' then -- quote marker
2310 Parse_Quoted(P, TID);
2311 end if;
2312 end Parse;
2313 end Parser;
-
+ 30ACFFBB85D590F74E7E9B76F5611663BDA26AF35E38316F633A752A9248AC9B7E61E72BD411252A4BE85B2F89E442F53F5E68A0414CFBBD6376B30F99F3B1BE
adalisp/src/parser.ads
(0 . 0)(1 . 56)
2318 -- S-expression parser. According to the current spec, any of the
2319 -- following objects constitute a S-expr:
2320 --
2321 -- - atom: a sequence containing any characters except spaces or parens,
2322 -- i.e. ( or ); atoms are separated by these characters and may not
2323 -- begin with any of (, ), #, . or '; if an atom is composed only of
2324 -- numeric decimal characters, then it is parsed as a number; otherwise
2325 -- it is parsed as an interned symbol.
2326 --
2327 -- - hash expression: any expression beginning with #; currently,
2328 -- expression beginning with # are the boolean values #t and #f, and
2329 -- escaped characters, e.g. #\a (the character corresponding to the
2330 -- letter a).
2331 --
2332 -- - cons expression: cons expressions begin with a (, contain any
2333 -- number of space-separated sub-expressions and end with ), e.g. (a b
2334 -- c d) denotes the list containing the symbols a, b, c and d, ()
2335 -- denotes the empty list, etc.; a cons expression may optionally
2336 -- contain a period (.) token before the last element, signifying that
2337 -- the last element is set as the cdr of the last cons cell, e.g. (1 2
2338 -- . 3) corresponds to (cons 1 (cons 2 3)).
2339 --
2340 -- - quoted expression: any expression beginning with a single quote (')
2341 -- token; 'expr (where expr is an arbitrary S-expression) gets
2342 -- translated to (quote expr).
2343 with LispM; use LispM;
2344
2345 package Parser is
2346 type TokenID is (Error_Token, Bool_Token, Num_Token, List_Token,
2347 Char_Token, Symbol_Token, ListE_Token, ListP_Token,
2348 Quoted_Token);
2349
2350 -- Given a string, check if all its characters are digits.
2351 procedure Parse_Integer(Str : in MemPtr;
2352 Success : out Boolean;
2353 I : out Long_Integer);
2354 -- Eat whitespace.
2355 procedure Eat_Whitespace;
2356
2357 -- Parse a list of characters not in the reserved set.
2358 procedure Parse_Atom(P : out MemPtr);
2359
2360 -- Parse a hash-prepended expression.
2361 procedure Parse_Hash(P : out MemPtr; TID : out TokenID);
2362
2363 -- Parse cons objects, i.e. lists and pairs.
2364 procedure Parse_Cons(P : out MemPtr);
2365
2366 -- Parse quoted expression.
2367 procedure Parse_Quoted(P : out MemPtr; TID : out TokenID);
2368
2369 -- Parse an S-expression given as input on the console. Output a
2370 -- pointer to the parsed expression and its type, as represented by
2371 -- TokenID.
2372 procedure Parse(P : out MemPtr; TID : out TokenID);
2373 end Parser;
-
+ 8AAF89145D930D102E76F08E51768E632C183155C4285D89D897CC5835E55DE3C9C1D27F847203D627198B4A919A138F31EAE131FBA600C5CF9507D4CD5C4064
adalisp/src/restrict.adc
(0 . 0)(1 . 65)
2378 pragma Restrictions(Immediate_Reclamation);
2379 pragma Restrictions(Max_Asynchronous_Select_Nesting => 0);
2380 pragma Restrictions(Max_Protected_Entries => 0);
2381 pragma Restrictions(Max_Select_Alternatives => 0);
2382 pragma Restrictions(Max_Task_Entries => 0);
2383 pragma Restrictions(Max_Tasks => 0);
2384 pragma Restrictions(No_Abort_Statements);
2385 pragma Restrictions(No_Access_Parameter_Allocators);
2386 pragma Restrictions(No_Allocators);
2387 pragma Restrictions(No_Asynchronous_Control);
2388 pragma Restrictions(No_Calendar);
2389 pragma Restrictions(No_Coextensions);
2390 pragma Restrictions(No_Default_Stream_Attributes);
2391 pragma Restrictions(No_Delay);
2392 pragma Restrictions(No_Dispatch);
2393 pragma Restrictions(No_Dispatching_Calls);
2394 pragma Restrictions(No_Dynamic_Attachment);
2395 pragma Restrictions(No_Dynamic_Priorities);
2396 pragma Restrictions(No_Entry_Calls_In_Elaboration_Code);
2397 pragma Restrictions(No_Entry_Queue);
2398 pragma Restrictions(No_Enumeration_Maps);
2399 pragma Restrictions(No_Exception_Propagation);
2400 pragma Restrictions(No_Exception_Registration);
2401 pragma Restrictions(No_Finalization);
2402 pragma Restrictions(No_Fixed_Io);
2403 pragma Restrictions(No_Floating_Point);
2404 pragma Restrictions(No_Implementation_Aspect_Specifications);
2405 pragma Restrictions(No_Implementation_Units);
2406 pragma Restrictions(No_Implicit_Aliasing);
2407 pragma Restrictions(No_Implicit_Conditionals);
2408 pragma Restrictions(No_Implicit_Dynamic_Code);
2409 pragma Restrictions(No_Implicit_Heap_Allocations);
2410 pragma Restrictions(No_Implicit_Protected_Object_Allocations);
2411 pragma Restrictions(No_Implicit_Task_Allocations);
2412 pragma Restrictions(No_Initialize_Scalars);
2413 pragma Restrictions(No_Local_Protected_Objects);
2414 pragma Restrictions(No_Local_Timing_Events);
2415 pragma Restrictions(No_Multiple_Elaboration);
2416 pragma Restrictions(No_Nested_Finalization);
2417 pragma Restrictions(No_Protected_Type_Allocators);
2418 pragma Restrictions(No_Protected_Types);
2419 pragma Restrictions(No_Relative_Delay);
2420 pragma Restrictions(No_Requeue_Statements);
2421 pragma Restrictions(No_Secondary_Stack);
2422 pragma Restrictions(No_Select_Statements);
2423 pragma Restrictions(No_Specific_Termination_Handlers);
2424 pragma Restrictions(No_Standard_Allocators_After_Elaboration);
2425 pragma Restrictions(No_Stream_Optimizations);
2426 pragma Restrictions(No_Streams);
2427 pragma Restrictions(No_Task_Allocators);
2428 pragma Restrictions(No_Task_At_Interrupt_Priority);
2429 pragma Restrictions(No_Task_Attributes_Package);
2430 pragma Restrictions(No_Task_Hierarchy);
2431 pragma Restrictions(No_Tasking);
2432 pragma Restrictions(No_Task_Termination);
2433 pragma Restrictions(No_Terminate_Alternatives);
2434 pragma Restrictions(No_Unchecked_Access);
2435 pragma Restrictions(No_Unchecked_Conversion);
2436 pragma Restrictions(No_Unchecked_Deallocation);
2437 pragma Restrictions(No_Wide_Characters);
2438 pragma Restrictions(Pure_Barriers);
2439 pragma Restrictions(Simple_Barriers);
2440 pragma Restrictions(Static_Priorities);
2441 pragma Restrictions(Static_Storage_Size);
2442 pragma Validity_Checks(ALL_CHECKS);
-
+ 040A9F08A31A01C5506C1609493F3E55833F5A0092144FA4A084739CC5EF75FBE8E2124C6C386607E9295A96D1BDD3B1F660D81C91668F481987E29B84EB7B14
adalisp/src/test_repl.adb
(0 . 0)(1 . 36)
2447 -- A test REPL putting all our Ada Lisp components together.
2448 with Ada.Text_IO; use Ada.Text_IO;
2449
2450 with Parser; use Parser;
2451 with Evaler; use Evaler;
2452 with LispM; use LispM;
2453
2454 procedure Test_Repl is
2455 P : MemPtr;
2456 TID : TokenID;
2457 begin
2458 -- Init builtin bindings
2459 Init_Builtin_Bindings;
2460
2461 loop
2462 Put("> ");
2463
2464 -- Read
2465 Parse(P, TID);
2466
2467 -- Eval
2468 case TID is
2469 when Error_Token =>
2470 Put("Parse error.");
2471 exit;
2472 when ListE_Token =>
2473 Put("Unexpected end of list.");
2474 exit;
2475 when others =>
2476 Eval(P, 0, P);
2477 end case;
2478
2479 -- Print
2480 Dump_Cell(P); Put_Line("");
2481 end loop;
2482 end Test_Repl;
-
+ 91D6AFD6207C6ECCA784175CADEFB5512CB50A310BFBE2AFA7DCEC1C221A01F1A12F5167DC8A6BF8C21D96642D04963509356D5FCE62F784584FE6365D327D5D
adalisp/test.scm
(0 . 0)(1 . 41)
2487 (define length (lambda (L)
2488 (if (eq? L '())
2489 0
2490 (+ 1 (length (cdr L))))))
2491
2492 (define map (lambda (f L)
2493 (if (eq? L '())
2494 '()
2495 (cons (f (car L)) (map f (cdr L))))))
2496
2497 (define fibs (lambda (n)
2498 (if (= n 0)
2499 0
2500 (if (= n 1)
2501 1
2502 (+ (fibs (- n 1)) (fibs (- n 2)))))))
2503
2504 (define fact (lambda (n)
2505 (if (= n 0)
2506 1
2507 (* n (fact (- n 1))))))
2508
2509 (define equal? (lambda (x y)
2510 (if (pair? x)
2511 (and (pair? y)
2512 (equal? (car x) (car y))
2513 (equal? (cdr x) (cdr y)))
2514 (eqv? x y))))
2515
2516 (define 1+ (lambda (x) (+ x 1)))
2517 (define 1- (lambda (x) (- x 1)))
2518
2519 (define succ 1+)
2520 (define pred 1-)
2521
2522 (if (= (length '(a b c d e f g)) 7) 'passed 'failed)
2523 (if (equal? (map (lambda (x) (* x x)) '(1 2 3 4 5))
2524 '(1 4 9 16 25))
2525 'passed 'failed)
2526 (if (= (fibs 10) 55) 'passed 'failed)
2527 (if (= (fact 10) 3628800) 'passed 'failed)
-
+ 9EC51C9DFDAC10BAA0E11529637447E9ED8B99D068144B966B6E8C653534CCE7BE30746D6AC834630758A14326353A1F12A560E06A9FF6B88DF151CF1A8A8158
adalisp/test_repl.gpr
(0 . 0)(1 . 48)
2532 project Test_Repl is
2533 for Object_Dir use "obj";
2534
2535 type Mode_Type is ("debug", "release");
2536 Mode : Mode_Type := external ("mode", "release");
2537
2538 for Languages use ("Ada");
2539 for Source_Dirs use ("src");
2540 for Exec_Dir use "bin";
2541 for Main use ("test_repl.adb");
2542
2543 package Compiler is
2544 case Mode is
2545 when "debug" =>
2546 for Switches ("Ada")
2547 use ("-g");
2548 when "release" =>
2549 for Switches ("Ada")
2550 use ("-O2", "-gnata", "-fstack-check",
2551 "-fdata-sections", "-ffunction-sections",
2552 "-gnatec=" & Test_Repl'Project_Dir & "src/restrict.adc");
2553 end case;
2554 end Compiler;
2555
2556 package Binder is
2557 case Mode is
2558 when "debug" =>
2559 for Switches ("Ada")
2560 use ();
2561 when "release" =>
2562 for Switches ("Ada")
2563 use ("-static");
2564 end case;
2565 end Binder;
2566
2567 package Linker is
2568 case Mode is
2569 when "debug" =>
2570 for Switches ("Ada")
2571 use ();
2572 when "release" =>
2573 for Switches ("Ada")
2574 use ("-Wl,--gc-sections",
2575 "-static");
2576 end case;
2577 end Linker;
2578
2579 end Test_Repl;