raw
adalisp_genesis         1 -- LispM evaluator implementation.
adalisp_genesis         2 
adalisp_genesis         3 with Ada.Text_IO; use Ada.Text_IO; -- for error reporting
adalisp_genesis         4 
adalisp_genesis         5 package body Evaler is
adalisp_genesis         6    
adalisp_genesis         7    -- An accumulator register for arithmetic/logic ops.
adalisp_genesis         8    ALU_Acc : Long_Integer := 0;
adalisp_genesis         9    
adalisp_genesis        10    -- Apply arithmetic and logic function, i.e. +, -, * or /
adalisp_genesis        11    procedure Apply_ALU_Func(Func : in ALUFunc;
adalisp_genesis        12                             Args : in MemPtr;
adalisp_genesis        13                             Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis        14       P, CarP : MemPtr;
adalisp_genesis        15    begin
adalisp_genesis        16       -- General form: (f e1 e2 ...) where f is one of +, -, * or
adalisp_genesis        17       --  /. Special cases:
adalisp_genesis        18       --
adalisp_genesis        19       -- - (+) --> 0
adalisp_genesis        20       -- - (- x) --> -x
adalisp_genesis        21       -- - (*) --> 1
adalisp_genesis        22       -- - (/ x) --> 1/x (always 0 for Fixnums)
adalisp_genesis        23       
adalisp_genesis        24       -- Initialize loop variables and perform argument count checks
adalisp_genesis        25       --  where needed.
adalisp_genesis        26       P := Args;
adalisp_genesis        27       case Func is
adalisp_genesis        28          when ALU_Add =>
adalisp_genesis        29             -- Identity element for +
adalisp_genesis        30             ALU_Acc := 0;
adalisp_genesis        31          when ALU_Sub =>
adalisp_genesis        32             -- - needs at least one argument
adalisp_genesis        33             pragma Assert(P /= 0, "- needs at least 1 argument");
adalisp_genesis        34             CarP := Get_Car(AMem(P));
adalisp_genesis        35             P := Get_Cdr(AMem(P));
adalisp_genesis        36             
adalisp_genesis        37             -- (- x) is arithmetic negation; (- x y ...) is equivalent
adalisp_genesis        38             --  to x - y - ...
adalisp_genesis        39             if (P = 0) then
adalisp_genesis        40                ALU_Acc := -Get_Fixnum(AMem(CarP));
adalisp_genesis        41             else
adalisp_genesis        42                ALU_Acc := Get_Fixnum(AMem(CarP));
adalisp_genesis        43             end if;
adalisp_genesis        44          when ALU_Mul =>
adalisp_genesis        45             -- Identity element for *
adalisp_genesis        46             ALU_Acc := 1;
adalisp_genesis        47          when ALU_Div =>
adalisp_genesis        48             -- / needs at least 1 argument
adalisp_genesis        49             pragma Assert(P /= 0, "/ needs at least 1 argument");
adalisp_genesis        50             CarP := Get_Car(AMem(P));
adalisp_genesis        51             P := Get_Cdr(AMem(P));
adalisp_genesis        52             
adalisp_genesis        53             -- (/ x) is 1 / x; (/ x y ...) is equivalent to x / y /
adalisp_genesis        54             --  ... ; we don't support floats, so 1 / x should always
adalisp_genesis        55             --  yield 0.
adalisp_genesis        56             if (P = 0) then
adalisp_genesis        57                ALU_Acc := 1 / Get_Fixnum(AMem(CarP));
adalisp_genesis        58             else
adalisp_genesis        59                ALU_Acc := Get_Fixnum(AMem(CarP));
adalisp_genesis        60             end if;
adalisp_genesis        61       end case;
adalisp_genesis        62       
adalisp_genesis        63       -- Loop through the arg list and accumulate.
adalisp_genesis        64       while P /= 0 loop
adalisp_genesis        65          -- Get car and accumulate it
adalisp_genesis        66          CarP := Get_Car(AMem(P));
adalisp_genesis        67          pragma Assert(AMem(CarP).T = Fixnum,
adalisp_genesis        68                        "Expected a number.");
adalisp_genesis        69          case Func is
adalisp_genesis        70             when ALU_Add =>
adalisp_genesis        71                ALU_Acc := ALU_Acc + Get_Fixnum(AMem(CarP));
adalisp_genesis        72             when ALU_Sub =>
adalisp_genesis        73                ALU_Acc := ALU_Acc - Get_Fixnum(AMem(CarP));
adalisp_genesis        74             when ALU_Mul =>
adalisp_genesis        75                ALU_Acc := ALU_Acc * Get_Fixnum(AMem(CarP));
adalisp_genesis        76             when ALU_Div =>
adalisp_genesis        77                pragma Assert(Get_Fixnum(AMem(CarP)) /= 0,
adalisp_genesis        78                              "Division by zero!");
adalisp_genesis        79                ALU_Acc := ALU_Acc / Get_Fixnum(AMem(CarP));
adalisp_genesis        80          end case;
adalisp_genesis        81          
adalisp_genesis        82          -- Continue
adalisp_genesis        83          P := Get_Cdr(AMem(P));
adalisp_genesis        84       end loop;
adalisp_genesis        85       -- Store value in a new cell and return it.
adalisp_genesis        86       Alloc_Fixnum(ALU_Acc, OutP);
adalisp_genesis        87    end Apply_ALU_Func;
adalisp_genesis        88    
adalisp_genesis        89    -- Apply unary predicate.
adalisp_genesis        90    procedure Apply_UPred(Pred : in UPred;
adalisp_genesis        91                          Args : in MemPtr;
adalisp_genesis        92                          Env : in MemPtr;
adalisp_genesis        93                          OutP : out MemPtr) is
adalisp_genesis        94       P : MemPtr := Args;
adalisp_genesis        95       ArgP : MemPtr;
adalisp_genesis        96    begin
adalisp_genesis        97       -- General form: (pred val) where pred is one of pair?, boolean?,
adalisp_genesis        98       --  number?, symbol?, null? or list?. Read below for
adalisp_genesis        99       --  particularities.
adalisp_genesis       100       
adalisp_genesis       101       -- Argument sanity checking
adalisp_genesis       102       pragma Assert(P /= 0, "Function requires 1 argument.");
adalisp_genesis       103       ArgP := Get_Car(AMem(P));
adalisp_genesis       104       P := Get_Cdr(AMem(P));
adalisp_genesis       105       pragma Assert(P = 0, "Function requires 1 argument.");
adalisp_genesis       106       
adalisp_genesis       107       -- What predicate op are we applying?
adalisp_genesis       108       case Pred is
adalisp_genesis       109          when UPred_Pair =>
adalisp_genesis       110             -- (pair? '()) --> #f
adalisp_genesis       111             -- (pair? anything-else) --> anything-else is a cons
adalisp_genesis       112             if ArgP = 0 then
adalisp_genesis       113                Alloc_Bool(False, OutP);
adalisp_genesis       114             else
adalisp_genesis       115                Alloc_Bool(AMem(ArgP).T = Cons, OutP);
adalisp_genesis       116             end if;
adalisp_genesis       117          when UPred_Bool =>
adalisp_genesis       118             -- (boolean? '()) --> #f
adalisp_genesis       119             -- (boolean? anything-else) --> anything-else is #t or #f
adalisp_genesis       120             if ArgP = 0 then
adalisp_genesis       121                Alloc_Bool(False, OutP);
adalisp_genesis       122             else
adalisp_genesis       123                Alloc_Bool(AMem(ArgP).T = Bool, OutP);
adalisp_genesis       124             end if;
adalisp_genesis       125          when UPred_Num =>
adalisp_genesis       126             -- (number? '()) --> #f
adalisp_genesis       127             -- (number? anything-else) --> anything-else is a fixnum
adalisp_genesis       128             if ArgP = 0 then
adalisp_genesis       129                Alloc_Bool(False, OutP);
adalisp_genesis       130             else
adalisp_genesis       131                Alloc_Bool(AMem(ArgP).T = Fixnum, OutP);
adalisp_genesis       132             end if;
adalisp_genesis       133          when UPred_Sym =>
adalisp_genesis       134             -- (symbol? '()) --> #f
adalisp_genesis       135             -- (symbol? 'anything-else) --> anything else is a symbol
adalisp_genesis       136             if ArgP = 0 then
adalisp_genesis       137                Alloc_Bool(False, OutP);
adalisp_genesis       138             else
adalisp_genesis       139                Alloc_Bool(AMem(ArgP).T = Symbol, OutP);
adalisp_genesis       140             end if;
adalisp_genesis       141          when UPred_Nil =>
adalisp_genesis       142             -- (null? '()) --> #t
adalisp_genesis       143             -- (null? anything-else) --> #f
adalisp_genesis       144             Alloc_Bool(ArgP = 0, OutP);
adalisp_genesis       145          when UPred_List =>
adalisp_genesis       146             -- (list? x) --> x is a proper-list, i.e. NIL or a form
adalisp_genesis       147             --  (cons e1 .. (cons en NIL))
adalisp_genesis       148             
adalisp_genesis       149             -- try walking through a list until NIL
adalisp_genesis       150             loop
adalisp_genesis       151                exit when ArgP = 0;
adalisp_genesis       152                exit when AMem(ArgP).T /= Cons;
adalisp_genesis       153                ArgP := Get_Cdr(AMem(ArgP));
adalisp_genesis       154             end loop;
adalisp_genesis       155             -- if a non-NIL is encountered anywhere in a cdr (or in the
adalisp_genesis       156             --  main object), then not a list.
adalisp_genesis       157             Alloc_Bool(ArgP = 0, OutP);
adalisp_genesis       158       end case;
adalisp_genesis       159    end Apply_UPred;
adalisp_genesis       160    
adalisp_genesis       161    -- Apply and/or special form.
adalisp_genesis       162    procedure Apply_AndOr(Cond : in AndOr;
adalisp_genesis       163                          Args : in MemPtr;
adalisp_genesis       164                          Env : in MemPtr;
adalisp_genesis       165                          OutP : out MemPtr) is
adalisp_genesis       166       P, ArgP : MemPtr;
adalisp_genesis       167       ReachedEnd : Boolean := False;      
adalisp_genesis       168    begin
adalisp_genesis       169       -- General form: (cond e1 e2 ...) where cond is one of and or
adalisp_genesis       170       --  or. Particularities:
adalisp_genesis       171       --
adalisp_genesis       172       -- - and evaluates until the end or the first #f encountered
adalisp_genesis       173       -- - or evaluates until the end or the first non-#f encountered
adalisp_genesis       174       --
adalisp_genesis       175       -- More details below.
adalisp_genesis       176       
adalisp_genesis       177       P := Args;
adalisp_genesis       178       if P = 0 then
adalisp_genesis       179          -- vacuous truth/falsity:
adalisp_genesis       180          -- (and) --> #t
adalisp_genesis       181          -- (or) --> #f
adalisp_genesis       182          ReachedEnd := True;
adalisp_genesis       183          Alloc_Bool(Cond = AndOr_And, ArgP);
adalisp_genesis       184       end if;
adalisp_genesis       185       loop
adalisp_genesis       186          -- have we reached the end?
adalisp_genesis       187          if P = 0 then
adalisp_genesis       188             ReachedEnd := True;
adalisp_genesis       189             exit;
adalisp_genesis       190          end if;         
adalisp_genesis       191          -- eval lazily:
adalisp_genesis       192          -- - and stops at the first argument evaluated to #f
adalisp_genesis       193          -- - or stops at the first argument evaluated to #t
adalisp_genesis       194          ArgP := Get_Car(AMem(P));
adalisp_genesis       195          Eval(ArgP, Env, ArgP);
adalisp_genesis       196          
adalisp_genesis       197          exit when Cond = AndOr_And and Boolean_Value(ArgP) = False;
adalisp_genesis       198          exit when Cond = AndOr_Or and Boolean_Value(ArgP) = True;
adalisp_genesis       199          
adalisp_genesis       200          -- continue
adalisp_genesis       201          P := Get_Cdr(AMem(P));
adalisp_genesis       202       end loop;
adalisp_genesis       203       
adalisp_genesis       204       -- Returned value:
adalisp_genesis       205       -- (and e1 e2 ...) returns #f or the last element
adalisp_genesis       206       -- (or e1 e2 ...) returns #f or the first non-#f element
adalisp_genesis       207       case Cond is
adalisp_genesis       208          when AndOr_And =>
adalisp_genesis       209             if ReachedEnd then
adalisp_genesis       210                OutP := ArgP;
adalisp_genesis       211             else
adalisp_genesis       212                Alloc_Bool(False, OutP);
adalisp_genesis       213             end if;
adalisp_genesis       214          when AndOr_Or =>
adalisp_genesis       215             if ReachedEnd then
adalisp_genesis       216                Alloc_Bool(False, OutP);
adalisp_genesis       217             else
adalisp_genesis       218                OutP := ArgP;
adalisp_genesis       219             end if;
adalisp_genesis       220       end case;
adalisp_genesis       221    end Apply_AndOr;
adalisp_genesis       222    
adalisp_genesis       223    -- Apply quote.
adalisp_genesis       224    procedure Apply_QuoteB(Args : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       225    begin
adalisp_genesis       226       -- General form:
adalisp_genesis       227       --
adalisp_genesis       228       -- (quote '()) --> ()
adalisp_genesis       229       -- (quote expr) --> expr
adalisp_genesis       230       
adalisp_genesis       231       OutP := (if Args = 0 then 0 else Get_Car(AMem(Args)));
adalisp_genesis       232    end Apply_QuoteB;
adalisp_genesis       233    
adalisp_genesis       234    -- Apply eval.
adalisp_genesis       235    procedure Apply_EvalB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       236       Arg : MemPtr;
adalisp_genesis       237    begin
adalisp_genesis       238       -- General form: (eval expr env), where expr is any S-expression
adalisp_genesis       239       --  and env is an optional environment (currently unimplemented).
adalisp_genesis       240       
adalisp_genesis       241       -- XXX: Need to do eval environments.
adalisp_genesis       242       pragma Assert(Args /= 0, "Eval needs at least 1 argument.");
adalisp_genesis       243       Arg := Get_Car(AMem(Args));
adalisp_genesis       244       -- Just call eval on arg
adalisp_genesis       245       Eval(Arg, Env, OutP);
adalisp_genesis       246    end Apply_EvalB;
adalisp_genesis       247    
adalisp_genesis       248    -- Apply if.
adalisp_genesis       249    procedure Apply_IfB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       250       P : MemPtr := Args;
adalisp_genesis       251       PredP : MemPtr;
adalisp_genesis       252       PredVal : Boolean;
adalisp_genesis       253    begin
adalisp_genesis       254       -- General form: (if pred a b) where pred, a and b are optional
adalisp_genesis       255       --  S-expressions. The evaluation rules are:
adalisp_genesis       256       --
adalisp_genesis       257       -- - (if) --> ()
adalisp_genesis       258       -- - (if pred) --> pred is evaluated and () is returned
adalisp_genesis       259       -- - (if pred a) --> pred is evaluated
adalisp_genesis       260       --   . if pred evals to #t, then a is evaluated and returned
adalisp_genesis       261       --   . otherwise, () is returned
adalisp_genesis       262       -- - (if pred a b) --> pred is evaluated
adalisp_genesis       263       --   . if pred evals to #t, then a is evaluated and returned
adalisp_genesis       264       --   . otherwise, b is evaluated and returned
adalisp_genesis       265       
adalisp_genesis       266       -- no args: (if) --> ()
adalisp_genesis       267       if P = 0 then
adalisp_genesis       268          OutP := 0;
adalisp_genesis       269          return;
adalisp_genesis       270       end if;
adalisp_genesis       271       
adalisp_genesis       272       -- get predicate, evaluate it and determine its boolean value
adalisp_genesis       273       --  (implicitly true for non-booleans)
adalisp_genesis       274       PredP := Get_Car(AMem(P));
adalisp_genesis       275       Eval(PredP, Env, PredP);
adalisp_genesis       276       PredVal := Boolean_Value(PredP);
adalisp_genesis       277       
adalisp_genesis       278       -- look for branches: P points to () or (a) or (a b)
adalisp_genesis       279       P := Get_Cdr(AMem(P));
adalisp_genesis       280       
adalisp_genesis       281       -- select branch: if pred evaluated to #f and the user specified
adalisp_genesis       282       --  (at least) the #t branch, then we cdr to the #f branch;
adalisp_genesis       283       --  otherwise, if no branches are specified, we return.
adalisp_genesis       284       if not PredVal and P /= 0 then
adalisp_genesis       285          P := Get_Cdr(AMem(P));
adalisp_genesis       286       elsif P = 0 then
adalisp_genesis       287          OutP := 0;
adalisp_genesis       288          return;
adalisp_genesis       289       end if;
adalisp_genesis       290       -- evaluate taken branch
adalisp_genesis       291       P := Get_Car(AMem(P));
adalisp_genesis       292       Eval(P, Env, OutP);
adalisp_genesis       293    end Apply_IfB;
adalisp_genesis       294    
adalisp_genesis       295    -- Apply cons.
adalisp_genesis       296    procedure Apply_ConsB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       297       P : MemPtr := Args;
adalisp_genesis       298       CarP, CdrP : MemPtr;
adalisp_genesis       299    begin
adalisp_genesis       300       -- General form: (cons a b) where a and b are S-expressions.
adalisp_genesis       301       
adalisp_genesis       302       pragma Assert(P /= 0, "Cons needs exactly 2 arguments.");
adalisp_genesis       303       -- get car
adalisp_genesis       304       CarP := Get_Car(AMem(P));
adalisp_genesis       305       -- get cdr
adalisp_genesis       306       P := Get_Cdr(AMem(P));
adalisp_genesis       307       pragma Assert(P /= 0, "Cons needs exactly 2 arguments.");
adalisp_genesis       308       CdrP := Get_Car(AMem(P));
adalisp_genesis       309       
adalisp_genesis       310       -- Rest of P needs to be nil now.
adalisp_genesis       311       P := Get_Cdr(AMem(P));
adalisp_genesis       312       pragma Assert(P = 0, "Cons needs exactly 2 arguments.");
adalisp_genesis       313       
adalisp_genesis       314       -- Cons the two
adalisp_genesis       315       Alloc_Cons(CarP, CdrP, OutP);
adalisp_genesis       316    end Apply_ConsB;
adalisp_genesis       317    
adalisp_genesis       318    -- Apply car.
adalisp_genesis       319    procedure Apply_CarB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       320       P : MemPtr := Args;
adalisp_genesis       321       ConsP : MemPtr;
adalisp_genesis       322    begin
adalisp_genesis       323       -- General form: (car x) where x is a cons.
adalisp_genesis       324       
adalisp_genesis       325       pragma Assert(P /= 0, "car needs exactly 1 argument.");
adalisp_genesis       326       -- Get x
adalisp_genesis       327       ConsP := Get_Car(AMem(P));
adalisp_genesis       328       pragma Assert (AMem(ConsP).T = Cons, "Expected pair.");
adalisp_genesis       329       OutP := Get_Car(AMem(ConsP));
adalisp_genesis       330       
adalisp_genesis       331       -- Rest of P needs to be nil
adalisp_genesis       332       P := Get_Cdr(AMem(P));
adalisp_genesis       333       pragma Assert (P = 0, "car needs exactly 1 argument.");
adalisp_genesis       334    end Apply_CarB;
adalisp_genesis       335    
adalisp_genesis       336    -- Apply cdr.
adalisp_genesis       337    procedure Apply_CdrB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       338       P : MemPtr := Args;
adalisp_genesis       339       ConsP : MemPtr;
adalisp_genesis       340    begin
adalisp_genesis       341       -- General form: (cdr x) where x is a cons.
adalisp_genesis       342       
adalisp_genesis       343       pragma Assert(P /= 0, "cdr needs exactly 1 argument.");
adalisp_genesis       344       -- Get x
adalisp_genesis       345       ConsP := Get_Car(AMem(P));
adalisp_genesis       346       pragma Assert (AMem(ConsP).T = Cons, "Expected pair.");
adalisp_genesis       347       OutP := Get_Cdr(AMem(ConsP));
adalisp_genesis       348       
adalisp_genesis       349       -- Rest of P needs to be nil
adalisp_genesis       350       P := Get_Cdr(AMem(P));
adalisp_genesis       351       pragma Assert (P = 0, "cdr needs exactly 1 argument.");
adalisp_genesis       352    end Apply_CdrB;
adalisp_genesis       353    
adalisp_genesis       354    -- Apply list.
adalisp_genesis       355    procedure Apply_ListB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       356    begin
adalisp_genesis       357       -- General form: (list e1 e2 ...) where e1 e2 ... are optional
adalisp_genesis       358       --  S-expressions.
adalisp_genesis       359       
adalisp_genesis       360       -- Applicative order evaluation is done by Apply_Func, so we just
adalisp_genesis       361       --  propagate the arguments.
adalisp_genesis       362       OutP := Args;
adalisp_genesis       363    end Apply_ListB;
adalisp_genesis       364    
adalisp_genesis       365    -- Apply apply.
adalisp_genesis       366    procedure Apply_ApplyB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       367       P : MemPtr := Args;
adalisp_genesis       368       OpP, ArgsP, LastArgP : MemPtr;
adalisp_genesis       369    begin
adalisp_genesis       370       -- General form: (apply f a1 a2 ... args) where f is a function,
adalisp_genesis       371       --  a1 a2 ... are S-expressions and args is a list.
adalisp_genesis       372       --
adalisp_genesis       373       --  The result is the same as applying f with (append (list a1 a2
adalisp_genesis       374       --  ...) args) as arguments.
adalisp_genesis       375       
adalisp_genesis       376       pragma Assert(P /= 0, "apply needs at least 1 argument.");
adalisp_genesis       377       
adalisp_genesis       378       -- get op
adalisp_genesis       379       OpP := Get_Car(AMem(P));
adalisp_genesis       380       
adalisp_genesis       381       -- get args: this section is roughly equivalent to list* (or
adalisp_genesis       382       --  cons*), i.e. (list* a1 a2 a3 ... args) --> (a1 a2 a3
adalisp_genesis       383       --  ... . args), i.e. we stick args in the butt of (a1 a2 a3 ...).
adalisp_genesis       384       P := Get_Cdr(AMem(P));
adalisp_genesis       385       -- first, we check if we have any args at all
adalisp_genesis       386       if P = 0 then goto DoApply; end if;
adalisp_genesis       387       -- if so, we do a shallow (reversed) copy of the list, accumulated
adalisp_genesis       388       --  in ArgsP; we put the car (the "args" above) in LastArgP and we
adalisp_genesis       389       --  keep the cdr in ArgsP.
adalisp_genesis       390       ArgsP := 0;
adalisp_genesis       391       while P /= 0 loop
adalisp_genesis       392          exit when AMem(P).T /= Cons;
adalisp_genesis       393          Alloc_Cons(Get_Car(AMem(P)), ArgsP, ArgsP);
adalisp_genesis       394          P := Get_Cdr(AMem(P));
adalisp_genesis       395       end loop;
adalisp_genesis       396       -- ArgsP has at least one element now!
adalisp_genesis       397       LastArgP := Get_Car(AMem(ArgsP));
adalisp_genesis       398       ArgsP := Get_Cdr(AMem(ArgsP));
adalisp_genesis       399       -- now put this in the proper form
adalisp_genesis       400       Rev_In_Place(ArgsP, LastArgP, P);
adalisp_genesis       401             
adalisp_genesis       402   <<DoApply>>
adalisp_genesis       403       -- Do the actual application
adalisp_genesis       404       Apply_Func(OpP, P, Env, True, OutP);
adalisp_genesis       405    end Apply_ApplyB;
adalisp_genesis       406    
adalisp_genesis       407    -- Apply define.
adalisp_genesis       408    procedure Apply_DefineB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       409       P : MemPtr := Args;
adalisp_genesis       410       SymP, ValP : MemPtr;
adalisp_genesis       411    begin
adalisp_genesis       412       -- General form: (define sym val) where sym is a symbol and val is
adalisp_genesis       413       --  an optional S-expression.
adalisp_genesis       414       --
adalisp_genesis       415       -- XXX we need to split this into two types of defines:
adalisp_genesis       416       --  symbol-defines (such as the one described here) and
adalisp_genesis       417       --  lambda-defines, e.g. (define (func arg1 ...) val).
adalisp_genesis       418       
adalisp_genesis       419       -- get sym
adalisp_genesis       420       SymP := Get_Car(AMem(P));
adalisp_genesis       421       pragma Assert (SymP /= 0, "Define: expected symbol for arg 1!");
adalisp_genesis       422       pragma Assert (AMem(SymP).T = Symbol,
adalisp_genesis       423                      "Define: expected symbol for arg 1!");
adalisp_genesis       424       
adalisp_genesis       425       -- get val: (define sym) binds sym to NIL.
adalisp_genesis       426       P := Get_Cdr(AMem(P));
adalisp_genesis       427       ValP := (if P = 0 then 0 else Get_Car(AMem(P)));
adalisp_genesis       428       
adalisp_genesis       429       -- evaluate val
adalisp_genesis       430       Eval(ValP, Env, ValP);
adalisp_genesis       431       -- make (top-level!) binding
adalisp_genesis       432       Bind_Env(SymP, ValP, Global_Env, P);
adalisp_genesis       433       -- return symbol name
adalisp_genesis       434       OutP := Get_Car(AMem(P));
adalisp_genesis       435    end Apply_DefineB;
adalisp_genesis       436 
adalisp_genesis       437    -- Apply set.
adalisp_genesis       438    procedure Apply_SetB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       439       P : MemPtr := Args;
adalisp_genesis       440       SymP, ValP : MemPtr;
adalisp_genesis       441       BindingP : MemPtr;
adalisp_genesis       442    begin
adalisp_genesis       443       -- General form: (set! sym val) where sym is a bound symbol and
adalisp_genesis       444       --  val is an optional S-expression. set! returns the evaluated
adalisp_genesis       445       --  val.
adalisp_genesis       446       
adalisp_genesis       447       pragma Assert(P /= 0, "set! requires at least 1 argument.");
adalisp_genesis       448       -- get sym
adalisp_genesis       449       SymP := Get_Car(AMem(P));
adalisp_genesis       450       -- and look it up in the scoped Envs
adalisp_genesis       451       Lookup_Env_Or_Global(SymP, Env, BindingP);
adalisp_genesis       452       -- binding must exist
adalisp_genesis       453       pragma Assert(BindingP /= 0, "set! got an unbound variable.");
adalisp_genesis       454       
adalisp_genesis       455       -- get value
adalisp_genesis       456       P := Get_Cdr(AMem(P));
adalisp_genesis       457       ValP := (if P = 0 then 0 else Get_Car(AMem(P)));
adalisp_genesis       458       -- eval it
adalisp_genesis       459       Eval(ValP, Env, ValP);
adalisp_genesis       460       -- and modify the binding
adalisp_genesis       461       Set_Cdr(AMem(BindingP), ValP);
adalisp_genesis       462       -- return the value
adalisp_genesis       463       OutP := ValP;
adalisp_genesis       464    end Apply_SetB;
adalisp_genesis       465    
adalisp_genesis       466    -- Apply numeric equality.
adalisp_genesis       467    procedure Apply_EqnB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       468       P : MemPtr := Args;
adalisp_genesis       469       Fst, Other : MemPtr;
adalisp_genesis       470       Result : MemPtr;
adalisp_genesis       471    begin
adalisp_genesis       472       -- General form: (= n1 n2 ...) where n1, n2, ... are numbers. =
adalisp_genesis       473       --  expects at least two numbers as parameters.
adalisp_genesis       474       
adalisp_genesis       475       pragma Assert(P /= 0, "= requires at least 2 arguments");
adalisp_genesis       476       -- get first number
adalisp_genesis       477       Fst := Get_Car(AMem(P));
adalisp_genesis       478       pragma Assert(AMem(Fst).T = Fixnum, "Expected numeric arguments.");
adalisp_genesis       479       -- move on to rest
adalisp_genesis       480       P := Get_Cdr(AMem(P));
adalisp_genesis       481       pragma Assert(P /= 0, "= requires at least 2 arguments");
adalisp_genesis       482       
adalisp_genesis       483       -- allocate result: assume all numbers are equal until found
adalisp_genesis       484       --  otherwise.
adalisp_genesis       485       Alloc_Bool(True, Result);
adalisp_genesis       486       -- loop through the other numbers
adalisp_genesis       487       while P /= 0 loop
adalisp_genesis       488          -- get other
adalisp_genesis       489          Other := Get_Car(AMem(P));
adalisp_genesis       490          pragma Assert(AMem(Other).T = Fixnum, "Expected numeric arguments.");
adalisp_genesis       491          -- check equality: we assume two's complement representation
adalisp_genesis       492          if AMem(Fst).Data /= AMem(Other).Data then
adalisp_genesis       493             Set_Bool(AMem(Result), False);
adalisp_genesis       494          end if;
adalisp_genesis       495          -- move on to next element of the arg list
adalisp_genesis       496          P := Get_Cdr(AMem(P));
adalisp_genesis       497       end loop;
adalisp_genesis       498       -- store result
adalisp_genesis       499       OutP := Result;
adalisp_genesis       500    end Apply_EqnB;
adalisp_genesis       501    
adalisp_genesis       502    -- Apply pointer equality.
adalisp_genesis       503    procedure Apply_EqB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       504       P : MemPtr := Args;
adalisp_genesis       505       P1, P2 : MemPtr;
adalisp_genesis       506    begin
adalisp_genesis       507       -- General form: (eq? x y) where x and y are S-expressions.
adalisp_genesis       508       
adalisp_genesis       509       -- get x
adalisp_genesis       510       pragma Assert(P /= 0, "eq? requires 2 arguments.");
adalisp_genesis       511       P1 := Get_Car(AMem(P));      
adalisp_genesis       512       P := Get_Cdr(AMem(P));
adalisp_genesis       513       
adalisp_genesis       514       -- get y
adalisp_genesis       515       pragma Assert(P /= 0, "eq? requires 2 arguments.");
adalisp_genesis       516       P2 := Get_Car(AMem(P));
adalisp_genesis       517       P := Get_Cdr(AMem(P));
adalisp_genesis       518       pragma Assert(P = 0, "eq? requires 2 arguments.");
adalisp_genesis       519       
adalisp_genesis       520       -- compare x and y. XXX this is a hack, but eq? guarantees that
adalisp_genesis       521       --  matching boolean values match, e.g. (eq? #f #f) --> #t. As an
adalisp_genesis       522       --  alternative, we could reserve two special cells for #f and #t,
adalisp_genesis       523       --  or give up the schemism altogether and use nil and everything
adalisp_genesis       524       --  else as booleans.
adalisp_genesis       525       --
adalisp_genesis       526       -- (eq? '() '()) --> #t
adalisp_genesis       527       -- (eq? 1 1) --> may be #f if the two instances of 1 have
adalisp_genesis       528       --  different memory locations.
adalisp_genesis       529       if P1 /= 0 and P2 /= 0 then
adalisp_genesis       530          if AMem(P1).T = Bool and AMem(P2).T = Bool then
adalisp_genesis       531             Alloc_Bool(AMem(P1).Data = AMem(P2).Data, OutP);
adalisp_genesis       532          else
adalisp_genesis       533             Alloc_Bool(P1 = P2, OutP);
adalisp_genesis       534          end if;
adalisp_genesis       535       else
adalisp_genesis       536          Alloc_Bool(P1 = P2, OutP);
adalisp_genesis       537       end if;
adalisp_genesis       538    end Apply_EqB;
adalisp_genesis       539    
adalisp_genesis       540    -- Apply value-wise equality.
adalisp_genesis       541    procedure Apply_EqvB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       542       P : MemPtr := Args;
adalisp_genesis       543       Val1, Val2 : MemPtr;
adalisp_genesis       544       Result : Boolean;
adalisp_genesis       545    begin
adalisp_genesis       546       -- General form: (eqv? x y) where x and y are
adalisp_genesis       547       --  S-expressions. Unlike eq?, eqv? compares the data found in the
adalisp_genesis       548       --  cells pointed to by x and y, with the exception of NIL
adalisp_genesis       549       --  pointers, which are compared pointer-wise.
adalisp_genesis       550       
adalisp_genesis       551       -- get x
adalisp_genesis       552       pragma Assert(P /= 0, "eqv? requires 2 arguments.");
adalisp_genesis       553       Val1 := Get_Car(AMem(P));
adalisp_genesis       554       P := Get_Cdr(AMem(P));
adalisp_genesis       555       
adalisp_genesis       556       -- get y
adalisp_genesis       557       pragma Assert(P /= 0, "eqv? requires 2 arguments.");
adalisp_genesis       558       Val2 := Get_Car(AMem(P));
adalisp_genesis       559       P := Get_Cdr(AMem(P));
adalisp_genesis       560       pragma Assert(P = 0, "eqv? requires 2 arguments.");
adalisp_genesis       561       
adalisp_genesis       562       -- (eqv? '() y) --> (null? y)
adalisp_genesis       563       -- (eqv? x y) (where x is non-NIL) --> values are equal, e.g.
adalisp_genesis       564       -- - (eqv? 1 1) --> #t
adalisp_genesis       565       -- - (eqv? '(1) '(1)) --> #f (comparison between values of cons cells)
adalisp_genesis       566       if Val1 = 0 then
adalisp_genesis       567          Result := Val2 = 0;
adalisp_genesis       568       else
adalisp_genesis       569          Result := AMem(Val1).Data = AMem(Val2).Data;
adalisp_genesis       570       end if;
adalisp_genesis       571       -- set result
adalisp_genesis       572       Alloc_Bool(Result, OutP);
adalisp_genesis       573    end Apply_EqvB;
adalisp_genesis       574    
adalisp_genesis       575    -- Apply not.
adalisp_genesis       576    procedure Apply_NotB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       577       P : MemPtr := Args;
adalisp_genesis       578       Val : MemPtr;
adalisp_genesis       579    begin
adalisp_genesis       580       -- General form: (not x) where x is a S-expression. not is
adalisp_genesis       581       --  evaluated using the following rules:
adalisp_genesis       582       -- - (not #f) --> #t
adalisp_genesis       583       -- - (not x) (x /= #f) --> #f
adalisp_genesis       584       
adalisp_genesis       585       -- get argument
adalisp_genesis       586       pragma Assert (P /= 0, "not requires 1 argument.");
adalisp_genesis       587       Val := Get_Car(AMem(P));
adalisp_genesis       588       P := Get_Cdr(AMem(P));
adalisp_genesis       589       pragma Assert (P = 0, "not requires 1 argument.");
adalisp_genesis       590       
adalisp_genesis       591       -- perform logic negation on boolean value.
adalisp_genesis       592       Alloc_Bool(not Boolean_Value(Val), OutP);
adalisp_genesis       593    end Apply_NotB;
adalisp_genesis       594    
adalisp_genesis       595    -- Apply lambda.
adalisp_genesis       596    procedure Apply_LambdaB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       597    begin
adalisp_genesis       598       -- General form: (lambda args e1 e2 ...) where args is a list of
adalisp_genesis       599       --  formal arguments (symbols) and e1 e2 ... are optional
adalisp_genesis       600       --  S-expressions that may contain references to the formal
adalisp_genesis       601       --  arguments; i.e., e1 e2 ... forms a lexical scope where the
adalisp_genesis       602       --  formal arguments are bound.
adalisp_genesis       603       --
adalisp_genesis       604       -- See Alloc_Closure for more details.
adalisp_genesis       605       Alloc_Closure(Args, Env, OutP);
adalisp_genesis       606    end Apply_LambdaB;
adalisp_genesis       607    
adalisp_genesis       608    -- Apply let.
adalisp_genesis       609    procedure Apply_LetB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       610       BndsP, CodeP : MemPtr;
adalisp_genesis       611       ArgsP, ValuesP, ClosureP : MemPtr;
adalisp_genesis       612    begin
adalisp_genesis       613       -- General form: (let bnds . code) where bnds is a list (bnd1 bnd2
adalisp_genesis       614       --  ...) and code is a list (e1 e2 ...). More precisely:
adalisp_genesis       615       --
adalisp_genesis       616       -- - bndi is a list of the form (si vi) where si is a symbol and
adalisp_genesis       617       --  vi is a mandatory S-expression.
adalisp_genesis       618       -- - ek is an optional S-expression that may contain references to
adalisp_genesis       619       --  si.
adalisp_genesis       620       --
adalisp_genesis       621       -- Lets do the following: 1. every vi is evaluated; 2. every
adalisp_genesis       622       --  evaluated vi is used as a lexical binding for the
adalisp_genesis       623       --  corresponding si; and 3. in the newly-created lexical scope,
adalisp_genesis       624       --  ek are evaluated in the order they appear in code.
adalisp_genesis       625       --
adalisp_genesis       626       -- More generally, any expression of the form:
adalisp_genesis       627       --
adalisp_genesis       628       -- (let ((s1 v1) (s2 v2) ... (sn vn)) e1 e2 ... em)
adalisp_genesis       629       --
adalisp_genesis       630       -- is equivalent to:
adalisp_genesis       631       --
adalisp_genesis       632       -- ((lambda (s1 s2 ... sn) e1 e2 ... em) v1 v2 ... vn).
adalisp_genesis       633       --
adalisp_genesis       634       -- Thus this implementation: 1. collects the formal arguments
adalisp_genesis       635       --  (names) in ArgsP and the effective arguments (values) in
adalisp_genesis       636       --  ValuesP; 2. collects the code in CodeP; 3. creates a closure
adalisp_genesis       637       --  ClosureP from the list (ArgsP . CodeP); 4. applies ClosureP on
adalisp_genesis       638       --  ValuesP.
adalisp_genesis       639       
adalisp_genesis       640       -- (let) --> ()
adalisp_genesis       641       if Args = 0 then
adalisp_genesis       642          -- nothing to do here
adalisp_genesis       643          OutP := 0;
adalisp_genesis       644          return;
adalisp_genesis       645       end if;
adalisp_genesis       646    
adalisp_genesis       647       -- get bindings and code; initialize arglist and valuelist
adalisp_genesis       648       BndsP := Get_Car(AMem(Args));
adalisp_genesis       649       CodeP := Get_Cdr(AMem(Args));
adalisp_genesis       650       ArgsP := 0; ValuesP := 0;
adalisp_genesis       651       
adalisp_genesis       652       -- collect formal args and effective values
adalisp_genesis       653       while BndsP /= 0 loop
adalisp_genesis       654          declare
adalisp_genesis       655             BndP : MemPtr := Get_Car(AMem(BndsP));
adalisp_genesis       656             SymP, ValP : MemPtr;
adalisp_genesis       657          begin
adalisp_genesis       658             pragma Assert(BndP /= 0, "Bad syntax of let spec.");
adalisp_genesis       659             pragma Assert(AMem(BndP).T = Cons, "Bad syntax of let spec.");
adalisp_genesis       660             
adalisp_genesis       661             -- get symbol and advance in BndP
adalisp_genesis       662             SymP := Get_Car(AMem(BndP));
adalisp_genesis       663             ValP := Get_Cdr(AMem(BndP));
adalisp_genesis       664             -- XXX: this is the stricter version
adalisp_genesis       665             pragma Assert (ValP /= 0, "Bad syntax of binding in let.");
adalisp_genesis       666             -- get val and evaluate it
adalisp_genesis       667             ValP := Get_Car(AMem(ValP));
adalisp_genesis       668             Eval(ValP, Env, ValP);
adalisp_genesis       669             -- add symbol to ArgsP, value to ValuesP
adalisp_genesis       670             Alloc_Cons(SymP, ArgsP, ArgsP);
adalisp_genesis       671             Alloc_Cons(ValP, ValuesP, ValuesP);
adalisp_genesis       672             -- continue
adalisp_genesis       673             BndsP := Get_Cdr(AMem(BndsP));
adalisp_genesis       674          end;
adalisp_genesis       675       end loop;
adalisp_genesis       676       
adalisp_genesis       677       -- cons args to code
adalisp_genesis       678       Alloc_Cons(ArgsP, CodeP, CodeP);
adalisp_genesis       679       -- make closure
adalisp_genesis       680       Apply_LambdaB(CodeP, Env, ClosureP);
adalisp_genesis       681       -- apply closure
adalisp_genesis       682       Apply_Closure(ClosureP, ValuesP, Env, OutP);
adalisp_genesis       683    end Apply_LetB;
adalisp_genesis       684    
adalisp_genesis       685    -- Apply reverse.
adalisp_genesis       686    procedure Apply_ReverseB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       687       P : MemPtr := Args;
adalisp_genesis       688       List : MemPtr;
adalisp_genesis       689    begin
adalisp_genesis       690       -- General form: (reverse x) where x is a list.
adalisp_genesis       691       
adalisp_genesis       692       -- get x
adalisp_genesis       693       pragma Assert (P /= 0, "reverse requires 1 argument.");
adalisp_genesis       694       List := Get_Car(AMem(P));
adalisp_genesis       695       P := Get_Cdr(AMem(P));
adalisp_genesis       696       pragma Assert (P = 0, "reverse requires 1 argument.");
adalisp_genesis       697       
adalisp_genesis       698       -- reverse x
adalisp_genesis       699       Rev_Append(0, List, OutP);
adalisp_genesis       700    end Apply_ReverseB;
adalisp_genesis       701    
adalisp_genesis       702    -- Apply append.
adalisp_genesis       703    procedure Apply_AppendB(Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       704       Lists : MemPtr := Args;
adalisp_genesis       705       Acc : MemPtr := 0;
adalisp_genesis       706    begin
adalisp_genesis       707       -- General form: (append x1 x2 ...) where x1 x2 ... are lists. In
adalisp_genesis       708       --  particular, the last xi may be any object, in which case the
adalisp_genesis       709       --  result of append is not a proper list, e.g.
adalisp_genesis       710       --
adalisp_genesis       711       -- - (append '(x) '(y)) --> (x y)
adalisp_genesis       712       -- - (append '(x y) 'z) --> (x y . z)
adalisp_genesis       713       
adalisp_genesis       714       -- (append) --> ()
adalisp_genesis       715       if Lists = 0 then
adalisp_genesis       716          OutP := 0;
adalisp_genesis       717          return;
adalisp_genesis       718       end if;
adalisp_genesis       719       
adalisp_genesis       720       -- accumulate in acc; stop when Lists has one element, so that we
adalisp_genesis       721       --  don't lose the reference to the last element.
adalisp_genesis       722       while Get_Cdr(AMem(Lists)) /= 0 loop
adalisp_genesis       723          -- prepend in reverse to Acc
adalisp_genesis       724          Rev_Append(Acc, Get_Car(AMem(Lists)), Acc);
adalisp_genesis       725          -- continue
adalisp_genesis       726          Lists := Get_Cdr(AMem(Lists));
adalisp_genesis       727       end loop;
adalisp_genesis       728       
adalisp_genesis       729       -- reverse Acc in place, adding the last element in Lists to the
adalisp_genesis       730       --  tail.
adalisp_genesis       731       Rev_In_Place(Acc, Get_Car(AMem(Lists)), Acc);
adalisp_genesis       732       OutP := Acc;
adalisp_genesis       733    end Apply_AppendB;
adalisp_genesis       734    
adalisp_genesis       735    -- Apply closure.
adalisp_genesis       736    procedure Apply_Closure(Op, Args, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       737       EArgs : MemPtr := Args;
adalisp_genesis       738       CArgs, CCode, CEnv : MemPtr;
adalisp_genesis       739    begin
adalisp_genesis       740       -- General form: (f a1 a2 ... an) where:
adalisp_genesis       741       --
adalisp_genesis       742       -- - f is a closure object, comprising an environment env (a list
adalisp_genesis       743       --  of bindings) and a code; the code is itself made of a list of
adalisp_genesis       744       --  formal parameters and a code body;
adalisp_genesis       745       -- - a1, a2 ... an, are arguments, i.e. effective parameters, to
adalisp_genesis       746       --  f, such that n is equal to the length of the list of formal
adalisp_genesis       747       --  parameters.
adalisp_genesis       748       --
adalisp_genesis       749       -- The application of f on the arguments is performed by binding
adalisp_genesis       750       --  each formal parameter to each corresponding argument, adding
adalisp_genesis       751       --  them to env and evaluating each expression in the code body in
adalisp_genesis       752       --  the (lexical) context of env.
adalisp_genesis       753       
adalisp_genesis       754       -- Initialize CArgs, CCode, CEnv.
adalisp_genesis       755       CEnv := Get_Closure_Env(AMem(Op));
adalisp_genesis       756       CCode := Get_Closure_Code(AMem(Op));
adalisp_genesis       757       -- Do we have an arglist and code?
adalisp_genesis       758       if CCode = 0 then
adalisp_genesis       759          CArgs := 0;
adalisp_genesis       760       else
adalisp_genesis       761          CArgs := Get_Car(AMem(CCode));
adalisp_genesis       762          CCode := Get_Cdr(AMem(CCode));
adalisp_genesis       763       end if;
adalisp_genesis       764       
adalisp_genesis       765       -- ((lambda () ...) ...)
adalisp_genesis       766       if CArgs = 0 then goto DoEval; end if;
adalisp_genesis       767       
adalisp_genesis       768       -- CArgs can be a:
adalisp_genesis       769       -- - symbol, e.g. ((lambda x (cdr x)) 1 2) --> (2)
adalisp_genesis       770       -- - list, e.g. ((lambda (x y) (+ x y)) 1 2) --> 3
adalisp_genesis       771       if AMem(CArgs).T = Symbol then
adalisp_genesis       772          -- extend env with a binding to effective arglist
adalisp_genesis       773          Alloc_Cons(CArgs, EArgs, CArgs);
adalisp_genesis       774          Alloc_Cons(CArgs, CEnv, CEnv);
adalisp_genesis       775       elsif AMem(CArgs).T = Cons then
adalisp_genesis       776          -- for each argument in CArgs corresponding to an actual value
adalisp_genesis       777          --  in EArgs, add a binding in CEnv.
adalisp_genesis       778          while CArgs /= 0 loop
adalisp_genesis       779             declare
adalisp_genesis       780                ArgP, ValP, BindingP : MemPtr;
adalisp_genesis       781             begin
adalisp_genesis       782                -- assert: (= (length CArgs) (length EArgs))
adalisp_genesis       783                pragma Assert(EArgs /= 0,
adalisp_genesis       784                              "Not enough arguments.");
adalisp_genesis       785                -- (cons (car CArgs) (car EArgs))
adalisp_genesis       786                ArgP := Get_Car(AMem(CArgs));
adalisp_genesis       787                ValP := Get_Car(AMem(EArgs));
adalisp_genesis       788                -- add binding to env, ignore non-symbols
adalisp_genesis       789                if ArgP /= 0 then
adalisp_genesis       790                   if AMem(ArgP).T = Symbol then
adalisp_genesis       791                      Alloc_Cons(ArgP, ValP, BindingP);
adalisp_genesis       792                      Alloc_Cons(BindingP, CEnv, CEnv);
adalisp_genesis       793                   end if;
adalisp_genesis       794                end if;
adalisp_genesis       795                -- continue with next argument
adalisp_genesis       796                CArgs := Get_Cdr(AMem(CArgs));
adalisp_genesis       797                EArgs := Get_Cdr(AMem(EArgs));
adalisp_genesis       798             end;
adalisp_genesis       799          end loop;
adalisp_genesis       800       else
adalisp_genesis       801          pragma Assert(False, "Expected symbol or cons.");
adalisp_genesis       802       end if;
adalisp_genesis       803       
adalisp_genesis       804   <<DoEval>>
adalisp_genesis       805       -- eval all coads
adalisp_genesis       806       while CCode /= 0 loop
adalisp_genesis       807          declare
adalisp_genesis       808             E : MemPtr;
adalisp_genesis       809          begin
adalisp_genesis       810             -- get current coad
adalisp_genesis       811             E := Get_Car(AMem(CCode));
adalisp_genesis       812             -- eval it, put result in OutP
adalisp_genesis       813             Eval(E, CEnv, OutP);
adalisp_genesis       814             -- continue
adalisp_genesis       815             CCode := Get_Cdr(AMem(CCode));
adalisp_genesis       816          end;
adalisp_genesis       817       end loop;
adalisp_genesis       818    end Apply_Closure;
adalisp_genesis       819 
adalisp_genesis       820    -- Apply a function on argument list.
adalisp_genesis       821    procedure Apply_Func(Op, Args, Env : in MemPtr;
adalisp_genesis       822                         Meta : in Boolean;
adalisp_genesis       823                         OutP : out MemPtr) is
adalisp_genesis       824       
adalisp_genesis       825       -- XXX: This should actually delimit between built-in functions
adalisp_genesis       826       --  and keywords; other functions (e.g. apply) may need to use
adalisp_genesis       827       --  this to provide relevant errors.
adalisp_genesis       828       Applicative_OrderP : constant array(BuiltinID) of Boolean :=
adalisp_genesis       829         (QuoteB | IfB | DefineB | SetB | AndB | OrB | LambdaB |
adalisp_genesis       830            LetB => False,
adalisp_genesis       831          others => True);
adalisp_genesis       832       
adalisp_genesis       833       BID : BuiltinID;
adalisp_genesis       834       EvaledArgs : MemPtr;
adalisp_genesis       835    begin
adalisp_genesis       836       pragma Assert(Op /= 0, "NIL op!");
adalisp_genesis       837       
adalisp_genesis       838       -- Is Op a builtin?
adalisp_genesis       839       if AMem(Op).T = Builtin then
adalisp_genesis       840          BID := Get_Builtin(AMem(Op));
adalisp_genesis       841          
adalisp_genesis       842          -- We want to evaluate the arguments before applying the
adalisp_genesis       843          --  function if:
adalisp_genesis       844          --  . the function permits it, or
adalisp_genesis       845          --  . Apply_Func was not called by apply (who already evals)
adalisp_genesis       846          if Applicative_OrderP(BID) and (not Meta) then
adalisp_genesis       847             Eval_List(Args, Env, EvaledArgs);
adalisp_genesis       848          else
adalisp_genesis       849             EvaledArgs := Args;
adalisp_genesis       850          end if;
adalisp_genesis       851          -- What builtin Op do we evaluate?
adalisp_genesis       852          case BID is
adalisp_genesis       853             when AddB => Apply_ALU_Func(ALU_Add, EvaledArgs, Env, OutP);
adalisp_genesis       854             when SubB => Apply_ALU_Func(ALU_Sub, EvaledArgs, Env, OutP);
adalisp_genesis       855             when MulB => Apply_ALU_Func(ALU_Mul, EvaledArgs, Env, OutP);
adalisp_genesis       856             when DivB => Apply_ALU_Func(ALU_Div, EvaledArgs, Env, OutP);
adalisp_genesis       857             when QuoteB => Apply_QuoteB(EvaledArgs, OutP);
adalisp_genesis       858             when EvalB => Apply_EvalB(EvaledArgs, Env, OutP);
adalisp_genesis       859             when IfB => Apply_IfB(EvaledArgs, Env, OutP);
adalisp_genesis       860             when ConsB => Apply_ConsB(EvaledArgs, Env, OutP);
adalisp_genesis       861             when CarB => Apply_CarB(EvaledArgs, Env, OutP);
adalisp_genesis       862             when CdrB => Apply_CdrB(EvaledArgs, Env, OutP);
adalisp_genesis       863             when ListB => Apply_ListB(EvaledArgs, Env, OutP);
adalisp_genesis       864             when ApplyB => Apply_ApplyB(EvaledArgs, Env, OutP);
adalisp_genesis       865             when DefineB => Apply_DefineB(EvaledArgs, Env, OutP);
adalisp_genesis       866             when SetB => Apply_SetB(EvaledArgs, Env, OutP);
adalisp_genesis       867             when EqnB => Apply_EqnB(EvaledArgs, Env, OutP);
adalisp_genesis       868             when EqB => Apply_EqB(EvaledArgs, Env, OutP);
adalisp_genesis       869             when EqvB => Apply_EqvB(EvaledArgs, Env, OutP);
adalisp_genesis       870             when PairPB => Apply_UPred(UPred_Pair, EvaledArgs, Env, OutP);
adalisp_genesis       871             when BooleanPB => Apply_UPred(UPred_Bool, EvaledArgs, Env, OutP);
adalisp_genesis       872             when NumberPB => Apply_UPred(UPred_Num, EvaledArgs, Env, OutP);
adalisp_genesis       873             when SymbolPB => Apply_UPred(UPred_Sym, EvaledArgs, Env, OutP);
adalisp_genesis       874             when NullPB => Apply_UPred(UPred_Nil, EvaledArgs, Env, OutP);
adalisp_genesis       875             when ListPB => Apply_UPred(UPred_List, EvaledArgs, Env, OutP);
adalisp_genesis       876             when AndB => Apply_AndOr(AndOr_And, EvaledArgs, Env, OutP);
adalisp_genesis       877             when OrB => Apply_AndOr(AndOr_Or, EvaledArgs, Env, OutP);
adalisp_genesis       878             when NotB => Apply_NotB(EvaledArgs, Env, OutP);
adalisp_genesis       879             when LambdaB => Apply_LambdaB(Args, Env, OutP);
adalisp_genesis       880             when LetB => Apply_LetB(Args, Env, OutP);
adalisp_genesis       881             when ReverseB => Apply_ReverseB(EvaledArgs, Env, OutP);
adalisp_genesis       882             when AppendB => Apply_AppendB(EvaledArgs, Env, OutP);
adalisp_genesis       883          end case;
adalisp_genesis       884       elsif AMem(Op).T = Closure then
adalisp_genesis       885          -- We evaluate the argument list only if this is not a
adalisp_genesis       886          --  meta-application (e.g. called by apply).
adalisp_genesis       887          if not Meta then
adalisp_genesis       888             Eval_List(Args, Env, EvaledArgs);
adalisp_genesis       889          else
adalisp_genesis       890             EvaledArgs := Args;
adalisp_genesis       891          end if;
adalisp_genesis       892          -- Apply closure.
adalisp_genesis       893          Apply_Closure(Op, EvaledArgs, Env, OutP);
adalisp_genesis       894       else
adalisp_genesis       895          OutP := 0;
adalisp_genesis       896          pragma Assert(False, "Trying to apply a non-function.");
adalisp_genesis       897       end if;
adalisp_genesis       898    end Apply_Func;
adalisp_genesis       899    
adalisp_genesis       900    -- Evaluate a list element by element.
adalisp_genesis       901    procedure Eval_List(List, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       902       LP : MemPtr := List;
adalisp_genesis       903       Result : MemPtr := 0;
adalisp_genesis       904       Default : MemPtr := 0;
adalisp_genesis       905    begin
adalisp_genesis       906       -- eval elements one by one
adalisp_genesis       907       while LP /= 0 loop
adalisp_genesis       908          declare
adalisp_genesis       909             TempP : MemPtr;
adalisp_genesis       910          begin
adalisp_genesis       911             -- degenerate case: cdr is neither list nor nil
adalisp_genesis       912             exit when AMem(LP).T /= Cons;
adalisp_genesis       913             -- eval current element in LP
adalisp_genesis       914             Eval(Get_Car(AMem(LP)), Env, TempP);
adalisp_genesis       915             -- cons result to Result
adalisp_genesis       916             Alloc_Cons(TempP, Result, Result);
adalisp_genesis       917             -- advance in LP
adalisp_genesis       918             LP := Get_Cdr(AMem(LP));
adalisp_genesis       919          end;
adalisp_genesis       920       end loop;
adalisp_genesis       921       
adalisp_genesis       922       -- also eval in the degenerate case
adalisp_genesis       923       if LP /= 0 then
adalisp_genesis       924          if AMem(LP).T /= Cons then
adalisp_genesis       925             Eval(LP, Env, Default);
adalisp_genesis       926          end if;
adalisp_genesis       927       end if;
adalisp_genesis       928 
adalisp_genesis       929       -- result is the reverse-in-place of our computation
adalisp_genesis       930       Rev_In_Place(Result, Default, OutP);
adalisp_genesis       931    end Eval_List;
adalisp_genesis       932 
adalisp_genesis       933    -- Evaluate a given S-expression
adalisp_genesis       934    procedure Eval(InP, Env : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       935       TempP, OpP, ArgsP : MemPtr;
adalisp_genesis       936    begin
adalisp_genesis       937       -- NIL.
adalisp_genesis       938       if (InP = 0) then
adalisp_genesis       939          OutP := 0;
adalisp_genesis       940          return;
adalisp_genesis       941       end if;
adalisp_genesis       942       
adalisp_genesis       943       -- Non-NIL data.
adalisp_genesis       944       case AMem(InP).T is
adalisp_genesis       945          when Free => -- this is illegal
adalisp_genesis       946             pragma Assert(False, "Trying to eval free cell!");
adalisp_genesis       947          when Cons =>
adalisp_genesis       948             -- Eval car to get Op
adalisp_genesis       949             TempP := Get_Car(AMem(InP));
adalisp_genesis       950             Eval(TempP, Env, OpP);
adalisp_genesis       951             -- Get arglist
adalisp_genesis       952             ArgsP := Get_Cdr(AMem(InP));
adalisp_genesis       953             -- Apply op on arglist
adalisp_genesis       954             Apply_Func(OpP, ArgsP, Env, False, OutP);
adalisp_genesis       955          when Bool | Fixnum | Char | Builtin | Closure  =>
adalisp_genesis       956             -- Constants are returned as they are.
adalisp_genesis       957             OutP := InP;
adalisp_genesis       958          when Symbol =>
adalisp_genesis       959             -- Lookup symbol value in Env.
adalisp_genesis       960             Lookup_Env_Or_Global(InP, Env, TempP);
adalisp_genesis       961             -- If found return it, otherwise report error.
adalisp_genesis       962             if TempP = 0 then
adalisp_genesis       963                Put("Not found: "); Dump_Cell(InP);
adalisp_genesis       964                pragma Assert(False, "No binding for symbol.");
adalisp_genesis       965             end if;
adalisp_genesis       966             OutP := Get_Cdr(AMem(TempP));
adalisp_genesis       967       end case;
adalisp_genesis       968    end Eval;
adalisp_genesis       969    
adalisp_genesis       970    -- Prepend the elements of B to A, in reverse.
adalisp_genesis       971    procedure Rev_Append(A, B : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       972       Acc : MemPtr := A;
adalisp_genesis       973       P : MemPtr := B;
adalisp_genesis       974    begin
adalisp_genesis       975       while P /= 0 loop
adalisp_genesis       976          exit when AMem(P).T /= Cons;
adalisp_genesis       977          Alloc_Cons(Get_Car(AMem(P)), Acc, Acc);
adalisp_genesis       978          P := Get_Cdr(AMem(P));
adalisp_genesis       979       end loop;
adalisp_genesis       980       
adalisp_genesis       981       pragma Assert (P = 0, "Non-list argument to append");
adalisp_genesis       982       
adalisp_genesis       983       OutP := Acc;
adalisp_genesis       984    end Rev_Append;
adalisp_genesis       985    
adalisp_genesis       986    procedure Rev_In_Place(List, Default : in MemPtr; OutP : out MemPtr) is
adalisp_genesis       987       P : MemPtr := List;
adalisp_genesis       988       Result : MemPtr := Default;
adalisp_genesis       989       Temp : MemPtr;
adalisp_genesis       990    begin
adalisp_genesis       991       while P /= 0 loop
adalisp_genesis       992          Temp := Get_Cdr(AMem(P)); -- save cdr
adalisp_genesis       993          Set_Cdr(AMem(P), Result); -- put partial result in tail
adalisp_genesis       994          Result := P; -- update result
adalisp_genesis       995          P := Temp; -- get cdr
adalisp_genesis       996       end loop;
adalisp_genesis       997       
adalisp_genesis       998       OutP := Result;
adalisp_genesis       999    end Rev_In_Place;
adalisp_genesis      1000    
adalisp_genesis      1001    -- Return the actual boolean associated with a Lisp value.
adalisp_genesis      1002    function Boolean_Value(P : MemPtr) return Boolean is
adalisp_genesis      1003    begin
adalisp_genesis      1004       -- Non-boolean values (including NIL) default to True. Boolean
adalisp_genesis      1005       --  values get the value of Get_Bool;         
adalisp_genesis      1006       if P = 0 then
adalisp_genesis      1007          return True;
adalisp_genesis      1008       elsif AMem(P).T = Bool then
adalisp_genesis      1009          return Get_Bool(AMem(P));
adalisp_genesis      1010       else
adalisp_genesis      1011          return True;
adalisp_genesis      1012       end if;
adalisp_genesis      1013    end Boolean_Value;
adalisp_genesis      1014 end Evaler;