-- LispM evaluator implementation. with Ada.Text_IO; use Ada.Text_IO; -- for error reporting package body Evaler is -- An accumulator register for arithmetic/logic ops. ALU_Acc : Long_Integer := 0; -- Apply arithmetic and logic function, i.e. +, -, * or / procedure Apply_ALU_Func(Func : in ALUFunc; Args : in MemPtr; Env : in MemPtr; OutP : out MemPtr) is P, CarP : MemPtr; begin -- General form: (f e1 e2 ...) where f is one of +, -, * or -- /. Special cases: -- -- - (+) --> 0 -- - (- x) --> -x -- - (*) --> 1 -- - (/ x) --> 1/x (always 0 for Fixnums) -- Initialize loop variables and perform argument count checks -- where needed. P := Args; case Func is when ALU_Add => -- Identity element for + ALU_Acc := 0; when ALU_Sub => -- - needs at least one argument pragma Assert(P /= 0, "- needs at least 1 argument"); CarP := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); -- (- x) is arithmetic negation; (- x y ...) is equivalent -- to x - y - ... if (P = 0) then ALU_Acc := -Get_Fixnum(AMem(CarP)); else ALU_Acc := Get_Fixnum(AMem(CarP)); end if; when ALU_Mul => -- Identity element for * ALU_Acc := 1; when ALU_Div => -- / needs at least 1 argument pragma Assert(P /= 0, "/ needs at least 1 argument"); CarP := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); -- (/ x) is 1 / x; (/ x y ...) is equivalent to x / y / -- ... ; we don't support floats, so 1 / x should always -- yield 0. if (P = 0) then ALU_Acc := 1 / Get_Fixnum(AMem(CarP)); else ALU_Acc := Get_Fixnum(AMem(CarP)); end if; end case; -- Loop through the arg list and accumulate. while P /= 0 loop -- Get car and accumulate it CarP := Get_Car(AMem(P)); pragma Assert(AMem(CarP).T = Fixnum, "Expected a number."); case Func is when ALU_Add => ALU_Acc := ALU_Acc + Get_Fixnum(AMem(CarP)); when ALU_Sub => ALU_Acc := ALU_Acc - Get_Fixnum(AMem(CarP)); when ALU_Mul => ALU_Acc := ALU_Acc * Get_Fixnum(AMem(CarP)); when ALU_Div => pragma Assert(Get_Fixnum(AMem(CarP)) /= 0, "Division by zero!"); ALU_Acc := ALU_Acc / Get_Fixnum(AMem(CarP)); end case; -- Continue P := Get_Cdr(AMem(P)); end loop; -- Store value in a new cell and return it. Alloc_Fixnum(ALU_Acc, OutP); end Apply_ALU_Func; -- Apply unary predicate. procedure Apply_UPred(Pred : in UPred; Args : in MemPtr; Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; ArgP : MemPtr; begin -- General form: (pred val) where pred is one of pair?, boolean?, -- number?, symbol?, null? or list?. Read below for -- particularities. -- Argument sanity checking pragma Assert(P /= 0, "Function requires 1 argument."); ArgP := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); pragma Assert(P = 0, "Function requires 1 argument."); -- What predicate op are we applying? case Pred is when UPred_Pair => -- (pair? '()) --> #f -- (pair? anything-else) --> anything-else is a cons if ArgP = 0 then Alloc_Bool(False, OutP); else Alloc_Bool(AMem(ArgP).T = Cons, OutP); end if; when UPred_Bool => -- (boolean? '()) --> #f -- (boolean? anything-else) --> anything-else is #t or #f if ArgP = 0 then Alloc_Bool(False, OutP); else Alloc_Bool(AMem(ArgP).T = Bool, OutP); end if; when UPred_Num => -- (number? '()) --> #f -- (number? anything-else) --> anything-else is a fixnum if ArgP = 0 then Alloc_Bool(False, OutP); else Alloc_Bool(AMem(ArgP).T = Fixnum, OutP); end if; when UPred_Sym => -- (symbol? '()) --> #f -- (symbol? 'anything-else) --> anything else is a symbol if ArgP = 0 then Alloc_Bool(False, OutP); else Alloc_Bool(AMem(ArgP).T = Symbol, OutP); end if; when UPred_Nil => -- (null? '()) --> #t -- (null? anything-else) --> #f Alloc_Bool(ArgP = 0, OutP); when UPred_List => -- (list? x) --> x is a proper-list, i.e. NIL or a form -- (cons e1 .. (cons en NIL)) -- try walking through a list until NIL loop exit when ArgP = 0; exit when AMem(ArgP).T /= Cons; ArgP := Get_Cdr(AMem(ArgP)); end loop; -- if a non-NIL is encountered anywhere in a cdr (or in the -- main object), then not a list. Alloc_Bool(ArgP = 0, OutP); end case; end Apply_UPred; -- Apply and/or special form. procedure Apply_AndOr(Cond : in AndOr; Args : in MemPtr; Env : in MemPtr; OutP : out MemPtr) is P, ArgP : MemPtr; ReachedEnd : Boolean := False; begin -- General form: (cond e1 e2 ...) where cond is one of and or -- or. Particularities: -- -- - and evaluates until the end or the first #f encountered -- - or evaluates until the end or the first non-#f encountered -- -- More details below. P := Args; if P = 0 then -- vacuous truth/falsity: -- (and) --> #t -- (or) --> #f ReachedEnd := True; Alloc_Bool(Cond = AndOr_And, ArgP); end if; loop -- have we reached the end? if P = 0 then ReachedEnd := True; exit; end if; -- eval lazily: -- - and stops at the first argument evaluated to #f -- - or stops at the first argument evaluated to #t ArgP := Get_Car(AMem(P)); Eval(ArgP, Env, ArgP); exit when Cond = AndOr_And and Boolean_Value(ArgP) = False; exit when Cond = AndOr_Or and Boolean_Value(ArgP) = True; -- continue P := Get_Cdr(AMem(P)); end loop; -- Returned value: -- (and e1 e2 ...) returns #f or the last element -- (or e1 e2 ...) returns #f or the first non-#f element case Cond is when AndOr_And => if ReachedEnd then OutP := ArgP; else Alloc_Bool(False, OutP); end if; when AndOr_Or => if ReachedEnd then Alloc_Bool(False, OutP); else OutP := ArgP; end if; end case; end Apply_AndOr; -- Apply quote. procedure Apply_QuoteB(Args : in MemPtr; OutP : out MemPtr) is begin -- General form: -- -- (quote '()) --> () -- (quote expr) --> expr OutP := (if Args = 0 then 0 else Get_Car(AMem(Args))); end Apply_QuoteB; -- Apply eval. procedure Apply_EvalB(Args, Env : in MemPtr; OutP : out MemPtr) is Arg : MemPtr; begin -- General form: (eval expr env), where expr is any S-expression -- and env is an optional environment (currently unimplemented). -- XXX: Need to do eval environments. pragma Assert(Args /= 0, "Eval needs at least 1 argument."); Arg := Get_Car(AMem(Args)); -- Just call eval on arg Eval(Arg, Env, OutP); end Apply_EvalB; -- Apply if. procedure Apply_IfB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; PredP : MemPtr; PredVal : Boolean; begin -- General form: (if pred a b) where pred, a and b are optional -- S-expressions. The evaluation rules are: -- -- - (if) --> () -- - (if pred) --> pred is evaluated and () is returned -- - (if pred a) --> pred is evaluated -- . if pred evals to #t, then a is evaluated and returned -- . otherwise, () is returned -- - (if pred a b) --> pred is evaluated -- . if pred evals to #t, then a is evaluated and returned -- . otherwise, b is evaluated and returned -- no args: (if) --> () if P = 0 then OutP := 0; return; end if; -- get predicate, evaluate it and determine its boolean value -- (implicitly true for non-booleans) PredP := Get_Car(AMem(P)); Eval(PredP, Env, PredP); PredVal := Boolean_Value(PredP); -- look for branches: P points to () or (a) or (a b) P := Get_Cdr(AMem(P)); -- select branch: if pred evaluated to #f and the user specified -- (at least) the #t branch, then we cdr to the #f branch; -- otherwise, if no branches are specified, we return. if not PredVal and P /= 0 then P := Get_Cdr(AMem(P)); elsif P = 0 then OutP := 0; return; end if; -- evaluate taken branch P := Get_Car(AMem(P)); Eval(P, Env, OutP); end Apply_IfB; -- Apply cons. procedure Apply_ConsB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; CarP, CdrP : MemPtr; begin -- General form: (cons a b) where a and b are S-expressions. pragma Assert(P /= 0, "Cons needs exactly 2 arguments."); -- get car CarP := Get_Car(AMem(P)); -- get cdr P := Get_Cdr(AMem(P)); pragma Assert(P /= 0, "Cons needs exactly 2 arguments."); CdrP := Get_Car(AMem(P)); -- Rest of P needs to be nil now. P := Get_Cdr(AMem(P)); pragma Assert(P = 0, "Cons needs exactly 2 arguments."); -- Cons the two Alloc_Cons(CarP, CdrP, OutP); end Apply_ConsB; -- Apply car. procedure Apply_CarB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; ConsP : MemPtr; begin -- General form: (car x) where x is a cons. pragma Assert(P /= 0, "car needs exactly 1 argument."); -- Get x ConsP := Get_Car(AMem(P)); pragma Assert (AMem(ConsP).T = Cons, "Expected pair."); OutP := Get_Car(AMem(ConsP)); -- Rest of P needs to be nil P := Get_Cdr(AMem(P)); pragma Assert (P = 0, "car needs exactly 1 argument."); end Apply_CarB; -- Apply cdr. procedure Apply_CdrB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; ConsP : MemPtr; begin -- General form: (cdr x) where x is a cons. pragma Assert(P /= 0, "cdr needs exactly 1 argument."); -- Get x ConsP := Get_Car(AMem(P)); pragma Assert (AMem(ConsP).T = Cons, "Expected pair."); OutP := Get_Cdr(AMem(ConsP)); -- Rest of P needs to be nil P := Get_Cdr(AMem(P)); pragma Assert (P = 0, "cdr needs exactly 1 argument."); end Apply_CdrB; -- Apply list. procedure Apply_ListB(Args, Env : in MemPtr; OutP : out MemPtr) is begin -- General form: (list e1 e2 ...) where e1 e2 ... are optional -- S-expressions. -- Applicative order evaluation is done by Apply_Func, so we just -- propagate the arguments. OutP := Args; end Apply_ListB; -- Apply apply. procedure Apply_ApplyB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; OpP, ArgsP, LastArgP : MemPtr; begin -- General form: (apply f a1 a2 ... args) where f is a function, -- a1 a2 ... are S-expressions and args is a list. -- -- The result is the same as applying f with (append (list a1 a2 -- ...) args) as arguments. pragma Assert(P /= 0, "apply needs at least 1 argument."); -- get op OpP := Get_Car(AMem(P)); -- get args: this section is roughly equivalent to list* (or -- cons*), i.e. (list* a1 a2 a3 ... args) --> (a1 a2 a3 -- ... . args), i.e. we stick args in the butt of (a1 a2 a3 ...). P := Get_Cdr(AMem(P)); -- first, we check if we have any args at all if P = 0 then goto DoApply; end if; -- if so, we do a shallow (reversed) copy of the list, accumulated -- in ArgsP; we put the car (the "args" above) in LastArgP and we -- keep the cdr in ArgsP. ArgsP := 0; while P /= 0 loop exit when AMem(P).T /= Cons; Alloc_Cons(Get_Car(AMem(P)), ArgsP, ArgsP); P := Get_Cdr(AMem(P)); end loop; -- ArgsP has at least one element now! LastArgP := Get_Car(AMem(ArgsP)); ArgsP := Get_Cdr(AMem(ArgsP)); -- now put this in the proper form Rev_In_Place(ArgsP, LastArgP, P); <> -- Do the actual application Apply_Func(OpP, P, Env, True, OutP); end Apply_ApplyB; -- Apply define. procedure Apply_DefineB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; SymP, ValP : MemPtr; begin -- General form: (define sym val) where sym is a symbol and val is -- an optional S-expression. -- -- XXX we need to split this into two types of defines: -- symbol-defines (such as the one described here) and -- lambda-defines, e.g. (define (func arg1 ...) val). -- get sym SymP := Get_Car(AMem(P)); pragma Assert (SymP /= 0, "Define: expected symbol for arg 1!"); pragma Assert (AMem(SymP).T = Symbol, "Define: expected symbol for arg 1!"); -- get val: (define sym) binds sym to NIL. P := Get_Cdr(AMem(P)); ValP := (if P = 0 then 0 else Get_Car(AMem(P))); -- evaluate val Eval(ValP, Env, ValP); -- make (top-level!) binding Bind_Env(SymP, ValP, Global_Env, P); -- return symbol name OutP := Get_Car(AMem(P)); end Apply_DefineB; -- Apply set. procedure Apply_SetB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; SymP, ValP : MemPtr; BindingP : MemPtr; begin -- General form: (set! sym val) where sym is a bound symbol and -- val is an optional S-expression. set! returns the evaluated -- val. pragma Assert(P /= 0, "set! requires at least 1 argument."); -- get sym SymP := Get_Car(AMem(P)); -- and look it up in the scoped Envs Lookup_Env_Or_Global(SymP, Env, BindingP); -- binding must exist pragma Assert(BindingP /= 0, "set! got an unbound variable."); -- get value P := Get_Cdr(AMem(P)); ValP := (if P = 0 then 0 else Get_Car(AMem(P))); -- eval it Eval(ValP, Env, ValP); -- and modify the binding Set_Cdr(AMem(BindingP), ValP); -- return the value OutP := ValP; end Apply_SetB; -- Apply numeric equality. procedure Apply_EqnB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; Fst, Other : MemPtr; Result : MemPtr; begin -- General form: (= n1 n2 ...) where n1, n2, ... are numbers. = -- expects at least two numbers as parameters. pragma Assert(P /= 0, "= requires at least 2 arguments"); -- get first number Fst := Get_Car(AMem(P)); pragma Assert(AMem(Fst).T = Fixnum, "Expected numeric arguments."); -- move on to rest P := Get_Cdr(AMem(P)); pragma Assert(P /= 0, "= requires at least 2 arguments"); -- allocate result: assume all numbers are equal until found -- otherwise. Alloc_Bool(True, Result); -- loop through the other numbers while P /= 0 loop -- get other Other := Get_Car(AMem(P)); pragma Assert(AMem(Other).T = Fixnum, "Expected numeric arguments."); -- check equality: we assume two's complement representation if AMem(Fst).Data /= AMem(Other).Data then Set_Bool(AMem(Result), False); end if; -- move on to next element of the arg list P := Get_Cdr(AMem(P)); end loop; -- store result OutP := Result; end Apply_EqnB; -- Apply pointer equality. procedure Apply_EqB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; P1, P2 : MemPtr; begin -- General form: (eq? x y) where x and y are S-expressions. -- get x pragma Assert(P /= 0, "eq? requires 2 arguments."); P1 := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); -- get y pragma Assert(P /= 0, "eq? requires 2 arguments."); P2 := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); pragma Assert(P = 0, "eq? requires 2 arguments."); -- compare x and y. XXX this is a hack, but eq? guarantees that -- matching boolean values match, e.g. (eq? #f #f) --> #t. As an -- alternative, we could reserve two special cells for #f and #t, -- or give up the schemism altogether and use nil and everything -- else as booleans. -- -- (eq? '() '()) --> #t -- (eq? 1 1) --> may be #f if the two instances of 1 have -- different memory locations. if P1 /= 0 and P2 /= 0 then if AMem(P1).T = Bool and AMem(P2).T = Bool then Alloc_Bool(AMem(P1).Data = AMem(P2).Data, OutP); else Alloc_Bool(P1 = P2, OutP); end if; else Alloc_Bool(P1 = P2, OutP); end if; end Apply_EqB; -- Apply value-wise equality. procedure Apply_EqvB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; Val1, Val2 : MemPtr; Result : Boolean; begin -- General form: (eqv? x y) where x and y are -- S-expressions. Unlike eq?, eqv? compares the data found in the -- cells pointed to by x and y, with the exception of NIL -- pointers, which are compared pointer-wise. -- get x pragma Assert(P /= 0, "eqv? requires 2 arguments."); Val1 := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); -- get y pragma Assert(P /= 0, "eqv? requires 2 arguments."); Val2 := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); pragma Assert(P = 0, "eqv? requires 2 arguments."); -- (eqv? '() y) --> (null? y) -- (eqv? x y) (where x is non-NIL) --> values are equal, e.g. -- - (eqv? 1 1) --> #t -- - (eqv? '(1) '(1)) --> #f (comparison between values of cons cells) if Val1 = 0 then Result := Val2 = 0; else Result := AMem(Val1).Data = AMem(Val2).Data; end if; -- set result Alloc_Bool(Result, OutP); end Apply_EqvB; -- Apply not. procedure Apply_NotB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; Val : MemPtr; begin -- General form: (not x) where x is a S-expression. not is -- evaluated using the following rules: -- - (not #f) --> #t -- - (not x) (x /= #f) --> #f -- get argument pragma Assert (P /= 0, "not requires 1 argument."); Val := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); pragma Assert (P = 0, "not requires 1 argument."); -- perform logic negation on boolean value. Alloc_Bool(not Boolean_Value(Val), OutP); end Apply_NotB; -- Apply lambda. procedure Apply_LambdaB(Args, Env : in MemPtr; OutP : out MemPtr) is begin -- General form: (lambda args e1 e2 ...) where args is a list of -- formal arguments (symbols) and e1 e2 ... are optional -- S-expressions that may contain references to the formal -- arguments; i.e., e1 e2 ... forms a lexical scope where the -- formal arguments are bound. -- -- See Alloc_Closure for more details. Alloc_Closure(Args, Env, OutP); end Apply_LambdaB; -- Apply let. procedure Apply_LetB(Args, Env : in MemPtr; OutP : out MemPtr) is BndsP, CodeP : MemPtr; ArgsP, ValuesP, ClosureP : MemPtr; begin -- General form: (let bnds . code) where bnds is a list (bnd1 bnd2 -- ...) and code is a list (e1 e2 ...). More precisely: -- -- - bndi is a list of the form (si vi) where si is a symbol and -- vi is a mandatory S-expression. -- - ek is an optional S-expression that may contain references to -- si. -- -- Lets do the following: 1. every vi is evaluated; 2. every -- evaluated vi is used as a lexical binding for the -- corresponding si; and 3. in the newly-created lexical scope, -- ek are evaluated in the order they appear in code. -- -- More generally, any expression of the form: -- -- (let ((s1 v1) (s2 v2) ... (sn vn)) e1 e2 ... em) -- -- is equivalent to: -- -- ((lambda (s1 s2 ... sn) e1 e2 ... em) v1 v2 ... vn). -- -- Thus this implementation: 1. collects the formal arguments -- (names) in ArgsP and the effective arguments (values) in -- ValuesP; 2. collects the code in CodeP; 3. creates a closure -- ClosureP from the list (ArgsP . CodeP); 4. applies ClosureP on -- ValuesP. -- (let) --> () if Args = 0 then -- nothing to do here OutP := 0; return; end if; -- get bindings and code; initialize arglist and valuelist BndsP := Get_Car(AMem(Args)); CodeP := Get_Cdr(AMem(Args)); ArgsP := 0; ValuesP := 0; -- collect formal args and effective values while BndsP /= 0 loop declare BndP : MemPtr := Get_Car(AMem(BndsP)); SymP, ValP : MemPtr; begin pragma Assert(BndP /= 0, "Bad syntax of let spec."); pragma Assert(AMem(BndP).T = Cons, "Bad syntax of let spec."); -- get symbol and advance in BndP SymP := Get_Car(AMem(BndP)); ValP := Get_Cdr(AMem(BndP)); -- XXX: this is the stricter version pragma Assert (ValP /= 0, "Bad syntax of binding in let."); -- get val and evaluate it ValP := Get_Car(AMem(ValP)); Eval(ValP, Env, ValP); -- add symbol to ArgsP, value to ValuesP Alloc_Cons(SymP, ArgsP, ArgsP); Alloc_Cons(ValP, ValuesP, ValuesP); -- continue BndsP := Get_Cdr(AMem(BndsP)); end; end loop; -- cons args to code Alloc_Cons(ArgsP, CodeP, CodeP); -- make closure Apply_LambdaB(CodeP, Env, ClosureP); -- apply closure Apply_Closure(ClosureP, ValuesP, Env, OutP); end Apply_LetB; -- Apply reverse. procedure Apply_ReverseB(Args, Env : in MemPtr; OutP : out MemPtr) is P : MemPtr := Args; List : MemPtr; begin -- General form: (reverse x) where x is a list. -- get x pragma Assert (P /= 0, "reverse requires 1 argument."); List := Get_Car(AMem(P)); P := Get_Cdr(AMem(P)); pragma Assert (P = 0, "reverse requires 1 argument."); -- reverse x Rev_Append(0, List, OutP); end Apply_ReverseB; -- Apply append. procedure Apply_AppendB(Args, Env : in MemPtr; OutP : out MemPtr) is Lists : MemPtr := Args; Acc : MemPtr := 0; begin -- General form: (append x1 x2 ...) where x1 x2 ... are lists. In -- particular, the last xi may be any object, in which case the -- result of append is not a proper list, e.g. -- -- - (append '(x) '(y)) --> (x y) -- - (append '(x y) 'z) --> (x y . z) -- (append) --> () if Lists = 0 then OutP := 0; return; end if; -- accumulate in acc; stop when Lists has one element, so that we -- don't lose the reference to the last element. while Get_Cdr(AMem(Lists)) /= 0 loop -- prepend in reverse to Acc Rev_Append(Acc, Get_Car(AMem(Lists)), Acc); -- continue Lists := Get_Cdr(AMem(Lists)); end loop; -- reverse Acc in place, adding the last element in Lists to the -- tail. Rev_In_Place(Acc, Get_Car(AMem(Lists)), Acc); OutP := Acc; end Apply_AppendB; -- Apply closure. procedure Apply_Closure(Op, Args, Env : in MemPtr; OutP : out MemPtr) is EArgs : MemPtr := Args; CArgs, CCode, CEnv : MemPtr; begin -- General form: (f a1 a2 ... an) where: -- -- - f is a closure object, comprising an environment env (a list -- of bindings) and a code; the code is itself made of a list of -- formal parameters and a code body; -- - a1, a2 ... an, are arguments, i.e. effective parameters, to -- f, such that n is equal to the length of the list of formal -- parameters. -- -- The application of f on the arguments is performed by binding -- each formal parameter to each corresponding argument, adding -- them to env and evaluating each expression in the code body in -- the (lexical) context of env. -- Initialize CArgs, CCode, CEnv. CEnv := Get_Closure_Env(AMem(Op)); CCode := Get_Closure_Code(AMem(Op)); -- Do we have an arglist and code? if CCode = 0 then CArgs := 0; else CArgs := Get_Car(AMem(CCode)); CCode := Get_Cdr(AMem(CCode)); end if; -- ((lambda () ...) ...) if CArgs = 0 then goto DoEval; end if; -- CArgs can be a: -- - symbol, e.g. ((lambda x (cdr x)) 1 2) --> (2) -- - list, e.g. ((lambda (x y) (+ x y)) 1 2) --> 3 if AMem(CArgs).T = Symbol then -- extend env with a binding to effective arglist Alloc_Cons(CArgs, EArgs, CArgs); Alloc_Cons(CArgs, CEnv, CEnv); elsif AMem(CArgs).T = Cons then -- for each argument in CArgs corresponding to an actual value -- in EArgs, add a binding in CEnv. while CArgs /= 0 loop declare ArgP, ValP, BindingP : MemPtr; begin -- assert: (= (length CArgs) (length EArgs)) pragma Assert(EArgs /= 0, "Not enough arguments."); -- (cons (car CArgs) (car EArgs)) ArgP := Get_Car(AMem(CArgs)); ValP := Get_Car(AMem(EArgs)); -- add binding to env, ignore non-symbols if ArgP /= 0 then if AMem(ArgP).T = Symbol then Alloc_Cons(ArgP, ValP, BindingP); Alloc_Cons(BindingP, CEnv, CEnv); end if; end if; -- continue with next argument CArgs := Get_Cdr(AMem(CArgs)); EArgs := Get_Cdr(AMem(EArgs)); end; end loop; else pragma Assert(False, "Expected symbol or cons."); end if; <> -- eval all coads while CCode /= 0 loop declare E : MemPtr; begin -- get current coad E := Get_Car(AMem(CCode)); -- eval it, put result in OutP Eval(E, CEnv, OutP); -- continue CCode := Get_Cdr(AMem(CCode)); end; end loop; end Apply_Closure; -- Apply a function on argument list. procedure Apply_Func(Op, Args, Env : in MemPtr; Meta : in Boolean; OutP : out MemPtr) is -- XXX: This should actually delimit between built-in functions -- and keywords; other functions (e.g. apply) may need to use -- this to provide relevant errors. Applicative_OrderP : constant array(BuiltinID) of Boolean := (QuoteB | IfB | DefineB | SetB | AndB | OrB | LambdaB | LetB => False, others => True); BID : BuiltinID; EvaledArgs : MemPtr; begin pragma Assert(Op /= 0, "NIL op!"); -- Is Op a builtin? if AMem(Op).T = Builtin then BID := Get_Builtin(AMem(Op)); -- We want to evaluate the arguments before applying the -- function if: -- . the function permits it, or -- . Apply_Func was not called by apply (who already evals) if Applicative_OrderP(BID) and (not Meta) then Eval_List(Args, Env, EvaledArgs); else EvaledArgs := Args; end if; -- What builtin Op do we evaluate? case BID is when AddB => Apply_ALU_Func(ALU_Add, EvaledArgs, Env, OutP); when SubB => Apply_ALU_Func(ALU_Sub, EvaledArgs, Env, OutP); when MulB => Apply_ALU_Func(ALU_Mul, EvaledArgs, Env, OutP); when DivB => Apply_ALU_Func(ALU_Div, EvaledArgs, Env, OutP); when QuoteB => Apply_QuoteB(EvaledArgs, OutP); when EvalB => Apply_EvalB(EvaledArgs, Env, OutP); when IfB => Apply_IfB(EvaledArgs, Env, OutP); when ConsB => Apply_ConsB(EvaledArgs, Env, OutP); when CarB => Apply_CarB(EvaledArgs, Env, OutP); when CdrB => Apply_CdrB(EvaledArgs, Env, OutP); when ListB => Apply_ListB(EvaledArgs, Env, OutP); when ApplyB => Apply_ApplyB(EvaledArgs, Env, OutP); when DefineB => Apply_DefineB(EvaledArgs, Env, OutP); when SetB => Apply_SetB(EvaledArgs, Env, OutP); when EqnB => Apply_EqnB(EvaledArgs, Env, OutP); when EqB => Apply_EqB(EvaledArgs, Env, OutP); when EqvB => Apply_EqvB(EvaledArgs, Env, OutP); when PairPB => Apply_UPred(UPred_Pair, EvaledArgs, Env, OutP); when BooleanPB => Apply_UPred(UPred_Bool, EvaledArgs, Env, OutP); when NumberPB => Apply_UPred(UPred_Num, EvaledArgs, Env, OutP); when SymbolPB => Apply_UPred(UPred_Sym, EvaledArgs, Env, OutP); when NullPB => Apply_UPred(UPred_Nil, EvaledArgs, Env, OutP); when ListPB => Apply_UPred(UPred_List, EvaledArgs, Env, OutP); when AndB => Apply_AndOr(AndOr_And, EvaledArgs, Env, OutP); when OrB => Apply_AndOr(AndOr_Or, EvaledArgs, Env, OutP); when NotB => Apply_NotB(EvaledArgs, Env, OutP); when LambdaB => Apply_LambdaB(Args, Env, OutP); when LetB => Apply_LetB(Args, Env, OutP); when ReverseB => Apply_ReverseB(EvaledArgs, Env, OutP); when AppendB => Apply_AppendB(EvaledArgs, Env, OutP); end case; elsif AMem(Op).T = Closure then -- We evaluate the argument list only if this is not a -- meta-application (e.g. called by apply). if not Meta then Eval_List(Args, Env, EvaledArgs); else EvaledArgs := Args; end if; -- Apply closure. Apply_Closure(Op, EvaledArgs, Env, OutP); else OutP := 0; pragma Assert(False, "Trying to apply a non-function."); end if; end Apply_Func; -- Evaluate a list element by element. procedure Eval_List(List, Env : in MemPtr; OutP : out MemPtr) is LP : MemPtr := List; Result : MemPtr := 0; Default : MemPtr := 0; begin -- eval elements one by one while LP /= 0 loop declare TempP : MemPtr; begin -- degenerate case: cdr is neither list nor nil exit when AMem(LP).T /= Cons; -- eval current element in LP Eval(Get_Car(AMem(LP)), Env, TempP); -- cons result to Result Alloc_Cons(TempP, Result, Result); -- advance in LP LP := Get_Cdr(AMem(LP)); end; end loop; -- also eval in the degenerate case if LP /= 0 then if AMem(LP).T /= Cons then Eval(LP, Env, Default); end if; end if; -- result is the reverse-in-place of our computation Rev_In_Place(Result, Default, OutP); end Eval_List; -- Evaluate a given S-expression procedure Eval(InP, Env : in MemPtr; OutP : out MemPtr) is TempP, OpP, ArgsP : MemPtr; begin -- NIL. if (InP = 0) then OutP := 0; return; end if; -- Non-NIL data. case AMem(InP).T is when Free => -- this is illegal pragma Assert(False, "Trying to eval free cell!"); when Cons => -- Eval car to get Op TempP := Get_Car(AMem(InP)); Eval(TempP, Env, OpP); -- Get arglist ArgsP := Get_Cdr(AMem(InP)); -- Apply op on arglist Apply_Func(OpP, ArgsP, Env, False, OutP); when Bool | Fixnum | Char | Builtin | Closure => -- Constants are returned as they are. OutP := InP; when Symbol => -- Lookup symbol value in Env. Lookup_Env_Or_Global(InP, Env, TempP); -- If found return it, otherwise report error. if TempP = 0 then Put("Not found: "); Dump_Cell(InP); pragma Assert(False, "No binding for symbol."); end if; OutP := Get_Cdr(AMem(TempP)); end case; end Eval; -- Prepend the elements of B to A, in reverse. procedure Rev_Append(A, B : in MemPtr; OutP : out MemPtr) is Acc : MemPtr := A; P : MemPtr := B; begin while P /= 0 loop exit when AMem(P).T /= Cons; Alloc_Cons(Get_Car(AMem(P)), Acc, Acc); P := Get_Cdr(AMem(P)); end loop; pragma Assert (P = 0, "Non-list argument to append"); OutP := Acc; end Rev_Append; procedure Rev_In_Place(List, Default : in MemPtr; OutP : out MemPtr) is P : MemPtr := List; Result : MemPtr := Default; Temp : MemPtr; begin while P /= 0 loop Temp := Get_Cdr(AMem(P)); -- save cdr Set_Cdr(AMem(P), Result); -- put partial result in tail Result := P; -- update result P := Temp; -- get cdr end loop; OutP := Result; end Rev_In_Place; -- Return the actual boolean associated with a Lisp value. function Boolean_Value(P : MemPtr) return Boolean is begin -- Non-boolean values (including NIL) default to True. Boolean -- values get the value of Get_Bool; if P = 0 then return True; elsif AMem(P).T = Bool then return Get_Bool(AMem(P)); else return True; end if; end Boolean_Value; end Evaler;