1110 lines
34 KiB
Ada
1110 lines
34 KiB
Ada
separate (H2.Scheme.Execute)
|
|
|
|
procedure Evaluate is
|
|
--pragma Inline (Evaluate);
|
|
|
|
Operand: aliased Object_Pointer;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
generic
|
|
Result: Object_Pointer; -- Result to return if no <test> expressions exist.
|
|
Opcode: Opcode_Type; -- Switch to this opcode to evaluate the next <test>.
|
|
procedure Generic_And_Or_Syntax;
|
|
|
|
procedure Generic_And_Or_Syntax is
|
|
begin
|
|
-- (and <test1> <test2> ...)
|
|
-- (and (= 2 2) (> 2 1)) ==> #t
|
|
-- (and (= 2 2) (< 2 1)) ==> #f
|
|
-- (and (= 2 2) (< 2 1) (= 3 3)) ==> #f
|
|
-- (and 1 2 'c '(f g)) ==> (f g)
|
|
-- (and) ==> #t
|
|
|
|
Operand := Get_Cdr(Operand); -- Skip "And"
|
|
if Operand = Nil_Pointer then
|
|
-- (and)
|
|
Return_Frame (Interp, Result);
|
|
elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then
|
|
-- (and . 10)
|
|
-- (and 1 2 . 10)
|
|
Ada.Text_IO.Put_LINE ("FUCKING CDR FOR DEFINE");
|
|
raise Syntax_Error;
|
|
else
|
|
--Switch_Frame (Interp.Stack, Opcode, Get_Cdr(Operand), Nil_Pointer); -- <test2> onwards
|
|
--Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand)); -- <test1>
|
|
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- <test2> onwards
|
|
Push_Subframe (Interp, Opcode, Get_Cdr(Operand)); -- <test1> onwards
|
|
end if;
|
|
end Generic_And_Or_Syntax;
|
|
|
|
procedure Evaluate_And_Syntax is new Generic_And_Or_Syntax(True_Pointer, Opcode_And_Finish);
|
|
procedure Evaluate_Or_Syntax is new Generic_And_Or_Syntax(False_Pointer, Opcode_Or_Finish);
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_Begin_Syntax is
|
|
pragma Inline (Evaluate_Begin_Syntax);
|
|
Synlist: Object_Pointer;
|
|
begin
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "begin"
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
|
|
if Operand /= Nil_Pointer and then
|
|
Get_Last_Cdr(Operand) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
if Operand = Nil_Pointer then
|
|
-- (begin)
|
|
-- Return nil to the upper frame for (begin).
|
|
Return_Frame (Interp, Nil_Pointer);
|
|
else
|
|
Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Operand, Nil_Pointer);
|
|
end if;
|
|
end Evaluate_Begin_Syntax;
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_Case_Syntax is
|
|
pragma Inline (Evaluate_Case_Syntax);
|
|
Synlist: Object_Pointer;
|
|
Ptr1: Object_Pointer;
|
|
Ptr2: Object_Pointer;
|
|
Ptr3: Object_Pointer;
|
|
begin
|
|
-- (case <key> <clause 1> <clause 2> ...)
|
|
-- <key> is an expression.
|
|
-- <clause> should be of the form:
|
|
-- ((<datum 1> ...) <expression 1> <expression 2> ...)
|
|
-- the last <clause> may be an else clause of the form:
|
|
-- (else <expression 1> <expression 2> ...)
|
|
--
|
|
-- (case (* 2 3)
|
|
-- ((2 3 5 7) 'prime)
|
|
-- ((1 4 6 8 9) 'composite))
|
|
--
|
|
-- (case (car '(c d))
|
|
-- ((a e i o u) 'vowel)
|
|
-- ((w y) 'semivowel)
|
|
-- (else 'consonant))
|
|
--
|
|
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "case"
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
|
|
if Not Is_Cons(Operand) then
|
|
-- e.g) (case)
|
|
-- (case . 10)
|
|
Ada.Text_IO.Put_LINE ("NO KEY FOR CASE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
--Key := Get_Car(Operand); -- <key>
|
|
|
|
Ptr1 := Get_Cdr(Operand); -- <clause> list.
|
|
while Is_Cons(Ptr1) loop
|
|
Ptr2 := Get_Car(Ptr1); -- <clause>
|
|
if Get_Last_Cdr(Ptr2) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR FOR CASE CLAUSE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr3 := Get_Car(Ptr2); -- <datum> list or 'else'
|
|
if Is_Cons(Ptr3) then
|
|
if Get_Last_Cdr(Ptr3) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_LINE ("FUCKING CDR FOR CASE DATUM");
|
|
raise Syntax_Error;
|
|
end if;
|
|
elsif Ptr3 = Interp.Else_Symbol then
|
|
-- check <test>. if it's else, it should be in the last clause.
|
|
if Is_Cons(Get_Cdr(Ptr1)) then
|
|
Ada.Text_IO.Put_Line ("ELSE NOT IN THE LAST CASE CLAUSE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
else
|
|
Ada.Text_IO.Put_LINE ("INVALID DATUM FOR CASE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if Get_Cdr(Ptr2) = Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("NO EXPRESSION IN CASE CLAUSE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr1 := Get_Cdr(Ptr1); -- next <clause> list
|
|
end loop;
|
|
|
|
if Ptr1 /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("FUCKING LAST CLAUSE FOR CASE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- <key>
|
|
Push_Subframe (Interp, Opcode_Case_Finish, Get_Cdr(Operand)); -- <clause> list
|
|
end Evaluate_Case_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_Cond_Syntax is
|
|
pragma Inline (Evaluate_Cond_Syntax);
|
|
Synlist: Object_Pointer;
|
|
begin
|
|
-- cond <clause 1> <clause 2> ...
|
|
-- A clause should be of the form:
|
|
-- (<test> <expression> ...)
|
|
-- the last clause may be an else clause of the form:
|
|
-- (else <expression> ...)
|
|
--
|
|
-- (cond ((> 3 2) 'greater)
|
|
-- ((< 3 2) 'less)) => greater
|
|
-- (cond ((> 3 3) 'greater)
|
|
-- ((< 3 3) 'less)
|
|
-- (else 'equal)) => equal
|
|
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "cond". <clause> list
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
if Not Is_Cons(Operand) then
|
|
-- e.g) (cond)
|
|
-- (cond . 10)
|
|
Ada.Text_IO.Put_LINE ("NO CLAUSE FOR COND");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
declare
|
|
Ptr1: Object_Pointer := Operand;
|
|
Ptr2: Object_Pointer;
|
|
begin
|
|
loop
|
|
Ptr2 := Get_Car(Ptr1); -- <clause>
|
|
if not Is_Cons(Ptr2) then
|
|
Ada.Text_IO.Put_Line ("FUCKING CLAUSE FOR COND");
|
|
raise Syntax_Error;
|
|
end if;
|
|
If Get_Last_Cdr(Ptr2) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR FOR COND CLAUSE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if Get_Car(Ptr2) = Interp.Else_Symbol then
|
|
-- check <test>. if it's else, it should be in the last clause.
|
|
if Is_Cons(Get_Cdr(Ptr1)) then
|
|
Ada.Text_IO.Put_Line ("ELSE NOT IN THE LAST COND CLAUSE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
end if;
|
|
|
|
Ptr1 := Get_Cdr(Ptr1); -- next <clause> list
|
|
exit when not Is_Cons(Ptr1);
|
|
end loop;
|
|
if Ptr1 /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("FUCKING LAST CLAUSE FOR COND");
|
|
raise Syntax_Error;
|
|
end if;
|
|
end;
|
|
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Get_Car(Operand)), Nil_Pointer); -- <test> in first <clause>
|
|
Push_Subframe (Interp, Opcode_Cond_Finish, Operand); -- <clause> list
|
|
end Evaluate_Cond_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_Define_Syntax is
|
|
pragma Inline (Evaluate_Define_Syntax);
|
|
Synlist: Object_Pointer;
|
|
Ptr1: Object_Pointer;
|
|
Ptr2: Object_Pointer;
|
|
Ptr3: Object_Pointer;
|
|
Ptr4: Object_Pointer;
|
|
begin
|
|
-- TODO: limit the context where define can be used.
|
|
|
|
-- (define <variable> <expression>)
|
|
-- (define (<variable> <formals>) <body>)
|
|
-- (define (<variable> . <formal>) <body>)
|
|
--
|
|
-- e.g)
|
|
-- (define x 10)
|
|
-- (define (add x y) (+ x y)) -> (define add (lambda (x y) (+ x y)))
|
|
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "define"
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
|
|
if not Is_Cons(Operand) or else not Is_Cons(Get_Cdr(Operand)) then
|
|
-- e.g) (define)
|
|
-- (define . 10)
|
|
-- (define x . 10)
|
|
Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR DEFINE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr1 := Get_Car(Operand);
|
|
if Is_Cons(Ptr1) then
|
|
-- (define (add x y) ...)
|
|
|
|
Ptr2 := Get_Car(Ptr1); -- <variable> as a function name
|
|
if not Is_Symbol(Ptr2) then
|
|
Ada.Text_IO.Put_LINE ("WRONG NAME FOR DEFINE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr1 := Get_Cdr(Ptr1); -- <formals>
|
|
Ptr2 := Ptr1;
|
|
|
|
while Is_Cons(Ptr2) loop
|
|
Ptr3 := Get_Car(Ptr2); -- <formal argument>
|
|
if not Is_Symbol(Ptr3) then
|
|
Ada.Text_IO.Put_Line ("WRONG FORMAL FOR LAMBDA");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
-- Check for a duplication formal argument
|
|
-- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated
|
|
Ptr4 := Ptr1;
|
|
while Ptr4 /= Ptr2 loop
|
|
if Get_Car(Ptr4) = Ptr3 then
|
|
Ada.Text_IO.Put_Line ("DUPLICATE FORMAL FOR DEFINE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
Ptr4 := Get_Cdr(Ptr4);
|
|
end loop;
|
|
|
|
-- Move on to the next formal argument
|
|
Ptr2 := Get_Cdr(Ptr2);
|
|
exit when not Is_Cons(Ptr2);
|
|
end loop;
|
|
|
|
if Ptr2 /= Nil_Pointer and then not Is_Symbol(Ptr2) then
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR DEFINE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr1 := Get_Cdr(Operand); -- <body>
|
|
if not Is_Cons(Ptr1) then
|
|
Ada.Text_IO.Put_Line ("NO BODY");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if Get_Last_Cdr(Ptr1) /= Nil_Pointer then
|
|
-- (lambda (x y) (+ x y) . 99)
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR IN BODY FOR LAMBDA");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
elsif Is_Symbol(Ptr1) then
|
|
if Get_Cdr(Get_Cdr(Operand)) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR DEFINE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
else
|
|
Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
Ptr1 := Get_Car(Operand);
|
|
if Is_Cons(Ptr1) then
|
|
-- define a function: (define (add x y) ...)
|
|
-- Get_Car(Ptr1) -- <variable>
|
|
-- Get_Cdr(Ptr1) -- <formals>
|
|
-- Get_Cdr(Operand) -- <body>
|
|
|
|
-- It's ok to not reload but switch because no continuation
|
|
-- can be created in this form of 'define'.
|
|
Switch_Frame (Interp.Stack, Opcode_Define_Finish, Get_Car(Ptr1), Nil_Pointer);
|
|
|
|
-- Make closure and set it as a frame result. Note this is done
|
|
-- after switching in order to avoid GC problems withoug using
|
|
-- Push_Top/Pop_Tops.
|
|
Ptr2 := Make_Cons(Interp.Self, Get_Cdr(Ptr1), Get_Cdr(Operand));
|
|
Ptr2 := Make_Closure(Interp.Self, Ptr2, Get_Frame_Environment(Interp.Stack));
|
|
Set_Frame_Result (Interp.Stack, Ptr2);
|
|
else
|
|
-- define a symbol: (define x ...)
|
|
pragma Assert (Is_Symbol(Ptr1));
|
|
|
|
-- Arrange to finish defining after value evaluation
|
|
-- and to evaluate the value part.
|
|
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Operand)), Nil_Pointer);
|
|
Push_Subframe (Interp, Opcode_Define_Finish, Ptr1);
|
|
end if;
|
|
end Evaluate_Define_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Check_Do_Syntax is
|
|
Ptr1: Object_Pointer;
|
|
Ptr2: Object_Pointer;
|
|
Ptr3: Object_Pointer;
|
|
begin
|
|
Ptr1 := Operand; -- <bindings> list
|
|
if not Is_Cons(Ptr1) then
|
|
-- (do)
|
|
-- (do . 10)
|
|
Ada.Text_IO.Put_LINE ("NO BIDNIGNS FOR DO");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr2 := Get_Car(Ptr1); -- <bindings>
|
|
while Is_Cons(Ptr2) loop
|
|
Ptr3 := Get_Car(Ptr2); -- <binding>
|
|
if not Is_Cons(Ptr3) then
|
|
-- (do (i) (#f))
|
|
Ada.Text_IO.Put_Line ("INVALID BINDING FOR DO");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if not Is_Symbol(Get_Car(Ptr3)) then -- <variable>
|
|
-- (do ((10 10)) (#f))
|
|
Ada.Text_IO.Put_Line ("INVALID BINDING VARIABLE FOR DO");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr3 := Get_Cdr(Ptr3); -- <init> cons
|
|
if not Is_Cons(Ptr3) then
|
|
-- (do ((i . 10)) (#f))
|
|
Ada.Text_IO.Put_Line ("NO INIT IN DO BINDING");
|
|
raise Syntax_Error;
|
|
end if;
|
|
-- Get_Car(Ptr3); -- <init>
|
|
|
|
Ptr3 := Get_Cdr(Ptr3); -- <step> cons
|
|
if Is_Cons(Ptr3) then
|
|
-- Get_Car(Ptr3); -- <step>
|
|
if Get_Cdr(Ptr3) /= Nil_Pointer then
|
|
-- (do ((i 0 10 20)) ... )
|
|
Ada.Text_IO.PUT_Line ("TOO MANY STEP EXPRESSIONS IN DO BINDING");
|
|
raise Syntax_Error;
|
|
end if;
|
|
elsif Ptr3 /= Nil_Pointer then
|
|
-- (do ((i 0 . 10)) ... )
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR in DO BIDNING");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr2 := Get_Cdr(Ptr2);
|
|
end loop;
|
|
if Ptr2 /= Nil_Pointer then
|
|
-- (do 10 . 10)
|
|
-- (do 10 (#f))
|
|
-- (do ((i 10) (j 20) . 10) (#f))
|
|
Ada.Text_IO.Put_LINE ("INVALID BINDINGS FOR DO");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr1 := Get_Cdr(Ptr1); -- <clause>
|
|
if not Is_Cons(Ptr1) then
|
|
-- (do ( (i 10) (j 20)))
|
|
-- (do ( (i 10) (j 20)) . #f)
|
|
Ada.Text_IO.Put_LINE ("NO CLAUSE FOR DO");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr2 := Get_Car(Ptr1); -- <test> in clause;
|
|
if not Is_Cons(Ptr2) then
|
|
-- (do ( (i 10) (j 20)) #f)
|
|
Ada.Text_IO.Put_Line ("INVALID CLAUSE TEST FOR DO");
|
|
raise Syntax_Error;
|
|
end if;
|
|
if Get_Last_Cdr(Ptr2) /= Nil_Pointer then
|
|
-- (do ( (i 10) (j 20)) (#f . 10))
|
|
-- (do ( (i 10) (j 20)) (#f 20 . 10))
|
|
Ada.Text_IO.Put_LINE ("FUCKING CDR IN CLAUSE FOR DO");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if Get_Last_Cdr(Ptr1) /= Nil_Pointer then
|
|
-- (do ( (i 10) (j 20 10)) (#f 20) . 10)
|
|
Ada.Text_IO.Put_LINE ("FUCKING CDR IN BODY FOR DO");
|
|
raise Syntax_Error;
|
|
end if;
|
|
end Check_Do_Syntax;
|
|
|
|
procedure Evaluate_Do_Syntax is
|
|
pragma Inline (Evaluate_Do_Syntax);
|
|
Synlist: Object_Pointer;
|
|
Bindings: aliased Object_Pointer;
|
|
Envir: aliased Object_Pointer;
|
|
begin
|
|
-- (do <bindings> <clause> <body>)
|
|
-- <bindings> should be of the form: ((<variable 1> <init 1> <step 1>) ...)
|
|
-- <clause> should be of the form: (<test> <expression> ...)
|
|
-- <body> is zero or more expressions.
|
|
--
|
|
-- * evaluate <init>.
|
|
-- * bind <variable> with the result.
|
|
-- * evaluate <test>
|
|
-- * if the result is false, evaluate <body>. evaluate <step>.
|
|
-- store it into <variable> and go back to evaluate <test>
|
|
-- * if the result is true, evaluate <expression> and exit.
|
|
--
|
|
-- (let ((x '(1 3 5 7 9)))
|
|
-- (do ((x x (cdr x))
|
|
-- (sum 0 (+ sum (car x)))) ; <bindings> x and sum
|
|
-- ((null? x) sum) ; <clause>. if <test> is true, exit do with sum.
|
|
-- )
|
|
-- )
|
|
--
|
|
-- (do (
|
|
-- (i 0 (+ i 1)) ; i = 0, for each iteration, +1
|
|
-- (j 0 (+ j 2)) ; j = 0, for each iteration, +2
|
|
-- )
|
|
--
|
|
-- ((= i 5) i) ; exit returning i if i becomes 5
|
|
--
|
|
-- (display (* i j)) ; evaluate these until it exits
|
|
-- (newline)
|
|
-- )
|
|
--
|
|
-- Infinite loop samples:
|
|
-- (do () (#f) (display i))
|
|
-- (do ((i 0)) (#f) (display i))
|
|
-- (do ((i 0)) (#f) (display i))
|
|
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "do"
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
Check_Do_Syntax;
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
Reload_Frame (Interp, Opcode_Do_Test, Operand);
|
|
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
|
|
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment
|
|
|
|
Bindings := Get_Car(Operand); -- <binding> list
|
|
if Is_Cons(Bindings) then -- <binding> list
|
|
-- <binding> list is not nil.
|
|
Push_Top (Interp, Envir'Unchecked_Access);
|
|
Push_Top (Interp, Bindings'Unchecked_Access);
|
|
Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
|
|
Push_Frame (Interp, Opcode_Do_Binding, Bindings); -- first <binding>
|
|
Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Bindings))), Envir); -- first <init>
|
|
Pop_Tops (Interp, 2);
|
|
--else
|
|
-- -- <binding> list is nil/empty.
|
|
-- -- (do () (#f ... ) ...)
|
|
-- Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Car(Get_Cdr(Operand)))); -- <test>
|
|
end if;
|
|
end Evaluate_Do_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_If_Syntax is
|
|
pragma Inline (Evaluate_If_Syntax);
|
|
Synlist: Object_Pointer;
|
|
begin
|
|
-- (if <test> <consequent>)
|
|
-- (if <test> <consequent> <alternate>)
|
|
-- e.g) (if (> 3 2) 'yes)
|
|
-- (if (> 3 2) 'yes 'no)
|
|
-- (if (> 3 2) (- 3 2) (+ 3 2))
|
|
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "if".
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
declare
|
|
Ptr: Object_Pointer := Operand;
|
|
begin
|
|
if Not Is_Cons(Ptr) then
|
|
-- e.g) (if)
|
|
-- (if . 10)
|
|
Ada.Text_IO.Put_LINE ("NO CONDITIONAL FOR IF");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr := Get_Cdr(Ptr); -- cons cell containg <consequent>
|
|
if not Is_Cons(Ptr) then
|
|
Ada.Text_IO.Put_Line ("NO CONSEQUENT FOR IF");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr := Get_Cdr(Ptr); -- cons cell containing <alternate>
|
|
if Ptr = Nil_Pointer then
|
|
-- no <alternate>. it's ok
|
|
null;
|
|
elsif not Is_Cons(Ptr) then
|
|
-- no <alternate> but reduncant cdr.
|
|
-- (if (> 3 2) 3 . 99)
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR FOR IF");
|
|
raise Syntax_Error;
|
|
|
|
elsif Get_Cdr(Ptr) /= Nil_Pointer then
|
|
-- (if (> 3 2) 3 2 . 99)
|
|
-- (if (> 3 2) 3 2 99)
|
|
Ada.Text_IO.Put_Line ("TOO MANY ARGUMENTS FOR IF");
|
|
raise Syntax_Error;
|
|
end if;
|
|
end;
|
|
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
-- Arrange to evaluate <consequent> or <alternate> after <test>
|
|
-- evaluation and to evaluate <test>. Use Switch_Frame/Push_Subframe
|
|
-- instead of Switch_Frame/Push_Frame for continuation to work.
|
|
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- <test>
|
|
Push_Subframe (Interp, Opcode_If_Finish, Get_Cdr(Operand)); -- <consequent> and later
|
|
end Evaluate_If_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_Lambda_Syntax is
|
|
pragma Inline (Evaluate_Lambda_Syntax);
|
|
Synlist: Object_Pointer;
|
|
begin
|
|
-- (lambda <formals> <body>)
|
|
-- e.g) (lambda (x y) (+ x y))
|
|
-- e.g) (lambda (x y . z) z)
|
|
-- e.g) (lambda x (car x))
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "lambda". cons cell pointing to <formals>
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
if not Is_Cons(Operand) then
|
|
-- e.g) (lambda)
|
|
-- (lambda . 10)
|
|
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR LAMBDA");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
declare
|
|
Ptr1: Object_Pointer;
|
|
Ptr2: Object_Pointer;
|
|
Ptr3: Object_Pointer;
|
|
Ptr4: Object_Pointer;
|
|
begin
|
|
|
|
Ptr1 := Get_Car(Operand); -- <formals>
|
|
if Ptr1 = Nil_Pointer or else Is_Symbol(Ptr1) then
|
|
-- (lambda () ...) or (lambda x ...)
|
|
-- nothing to do
|
|
null;
|
|
elsif Is_Cons(Ptr1) then
|
|
Ptr2 := Ptr1;
|
|
loop
|
|
Ptr3 := Get_Car(Ptr2); -- <formal argument>
|
|
if not Is_Symbol(Ptr3) then
|
|
Ada.Text_IO.Put_Line ("WRONG FORMAL FOR LAMBDA");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
-- Check for a duplication formal argument
|
|
-- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated
|
|
Ptr4 := Ptr1;
|
|
while Ptr4 /= Ptr2 loop
|
|
if Get_Car(Ptr4) = Ptr3 then
|
|
Ada.Text_IO.Put_Line ("DUPLICATE FORMAL FOR LAMBDA");
|
|
raise Syntax_Error;
|
|
end if;
|
|
Ptr4 := Get_Cdr(Ptr4);
|
|
end loop;
|
|
|
|
-- Move on to the next formal argument
|
|
Ptr2 := Get_Cdr(Ptr2);
|
|
exit when not Is_Cons(Ptr2);
|
|
end loop;
|
|
|
|
if Ptr2 /= Nil_Pointer and then not Is_Symbol(Ptr2) then
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA");
|
|
raise Syntax_Error;
|
|
end if;
|
|
else
|
|
Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr1 := Get_Cdr(Operand); -- cons cell containing <body>
|
|
if not Is_Cons(Ptr1) then
|
|
Ada.Text_IO.Put_Line ("NO BODY");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if Get_Last_Cdr(Ptr1) /= Nil_Pointer then
|
|
-- (lambda (x y) (+ x y) . 99)
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR IN BODY FOR LAMBDA");
|
|
raise Syntax_Error;
|
|
end if;
|
|
end;
|
|
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
-- Create a closure object and return it the the upper frame.
|
|
Return_Frame (Interp, Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack)));
|
|
end Evaluate_Lambda_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Check_Let_Syntax is
|
|
pragma Inline (Check_Let_Syntax);
|
|
Bindings: Object_Pointer;
|
|
LetBody: Object_Pointer;
|
|
begin
|
|
-- (let <bindings> <body>)
|
|
if not Is_Cons(Operand) then
|
|
-- e.g) (let)
|
|
-- (let . 10)
|
|
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR LET");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Bindings := Get_Car(Operand); -- <bindings>
|
|
if Bindings /= Nil_Pointer and then not Is_Cons(Bindings) then
|
|
Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Letbody := Get_Cdr(Operand); -- Cons cell to <body>
|
|
if not Is_Cons(Letbody) or else Get_Last_Cdr(Letbody) /= Nil_Pointer then
|
|
-- (let ((x 2)) )
|
|
-- (let ((x 2)) . 99)
|
|
-- (let ((x 2)) (+ x 2) . 99)
|
|
Ada.Text_IO.Put_Line ("INVALID BODY FOR LET");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if Is_Cons(Bindings) then
|
|
declare
|
|
Ptr1: Object_Pointer := Bindings;
|
|
Ptr2: Object_Pointer;
|
|
Ptr3: Object_Pointer;
|
|
begin
|
|
loop
|
|
Ptr2 := Get_Car(Ptr1); -- <binding>
|
|
if not Is_Cons(Ptr2) or else not Is_Cons(Get_Cdr(Ptr2)) or else Get_Cdr(Get_Cdr(Ptr2)) /= Nil_Pointer then
|
|
-- no binding name or no binding value or garbage after that
|
|
Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Ptr2 := Get_Car(Ptr2); -- <binding> name
|
|
if not Is_Symbol(Ptr2) then
|
|
Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
-- Check for a duplicate binding name
|
|
-- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated
|
|
Ptr3 := Bindings;
|
|
while Ptr3 /= Ptr1 loop
|
|
if Get_Car(Get_Car(Ptr3)) = Ptr2 then
|
|
Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET");
|
|
raise Syntax_Error;
|
|
end if;
|
|
Ptr3 := Get_Cdr(Ptr3);
|
|
end loop;
|
|
|
|
-- Move on to the next binding
|
|
Ptr1 := Get_Cdr(Ptr1);
|
|
exit when not Is_Cons(Ptr1);
|
|
end loop;
|
|
|
|
if Ptr1 /= Nil_Pointer then
|
|
-- The last cdr is not nil.
|
|
Ada.Text_IO.Put_Line ("FUCKING CDR FOR LET BINDING");
|
|
raise Syntax_Error;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end Check_Let_Syntax;
|
|
|
|
procedure Evaluate_Let_Syntax is
|
|
pragma Inline (Evaluate_Let_Syntax);
|
|
Synlist: Object_Pointer;
|
|
Envir: aliased Object_Pointer;
|
|
Bindings: aliased Object_Pointer;
|
|
begin
|
|
-- Some let samples:
|
|
-- #1.
|
|
-- (define x 99) ; define x in the root environment
|
|
-- (let () (define x 100)) ; x is defined in the new environment.
|
|
-- x ; this must be 99.
|
|
--
|
|
-- #2.
|
|
-- (define x 10) ; x-outer
|
|
-- (define y (let ((x (+ x 1))) x)) ; x-inner := x-outer + 1, y := x-inner
|
|
-- y ; 11
|
|
-- x ; 10
|
|
--
|
|
-- #3.
|
|
-- (define x (let ((x x)) x))
|
|
--
|
|
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "let".
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
Check_Let_Syntax;
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
-- Switch the frame to Opcode_Grouped_Call and let its environment
|
|
-- be the new environment created. Use Reload_Frame() instead
|
|
-- of Switch_Frame() for continuation. This frame is executed once
|
|
-- the Opcode_Let_Binding frame pushed in the 'if' block is finished.
|
|
Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(Operand)); -- <body>
|
|
|
|
-- Create a new environment over the current environment.
|
|
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
|
|
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment
|
|
|
|
Bindings := Get_Car(Operand); -- <bindings>
|
|
if Bindings /= Nil_Pointer then
|
|
-- <bindings> is not empty
|
|
|
|
Push_Top (Interp, Envir'Unchecked_Access);
|
|
Push_Top (Interp, Bindings'Unchecked_Access);
|
|
|
|
Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
|
|
|
|
-- Say, <bindings> is ((x 2) (y 2)).
|
|
-- Get_Car(Bindings) is (x 2).
|
|
-- To get x, Get_Car(Get_Car(Bindings))
|
|
-- To get 2, Get_Car(Get_Cdr(Get_Car(Bindings)))
|
|
|
|
-- Arrange to evaluate the first <binding> expression in the parent environment.
|
|
Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Bindings))), Envir);
|
|
|
|
-- Arrange to perform actual binding. Pass the <binding> name as an intermediate
|
|
-- and the next remaing <binding> list as an operand.
|
|
Push_Subframe_With_Environment_And_Intermediate (Interp, Opcode_Let_Binding, Get_Cdr(Bindings), Envir, Get_Car(Get_Car(Bindings)));
|
|
|
|
Pop_Tops (Interp, 2);
|
|
end if;
|
|
end Evaluate_Let_Syntax;
|
|
|
|
procedure Evaluate_Letast_Syntax is
|
|
pragma Inline (Evaluate_Letast_Syntax);
|
|
Synlist: Object_Pointer;
|
|
Envir: aliased Object_Pointer;
|
|
Bindings: aliased Object_Pointer;
|
|
begin
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "let".
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
Check_Let_Syntax;
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(Operand)); -- <body>
|
|
|
|
-- Create a new environment over the current environment.
|
|
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
|
|
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment
|
|
|
|
Bindings := Get_Car(Operand); -- <bindings>
|
|
if Bindings /= Nil_Pointer then
|
|
-- <bindings> is not empty
|
|
|
|
Push_Top (Interp, Envir'Unchecked_Access);
|
|
Push_Top (Interp, Bindings'Unchecked_Access);
|
|
|
|
-- Say, <bindings> is ((x 2) (y 2)).
|
|
-- Get_Car(Bindings) is (x 2).
|
|
-- To get x, Get_Car(Get_Car(Bindings))
|
|
-- To get 2, Get_Car(Get_Cdr(Get_Car(Bindings)))
|
|
|
|
-- Arrange to evaluate the first <binding> expression in the parent environment.
|
|
Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Bindings))), Envir);
|
|
|
|
-- Arrange to perform actual binding. Pass the <binding> name as an intermediate
|
|
-- and the next remaing <binding> list as an operand.
|
|
Push_Subframe_With_Environment_And_Intermediate (Interp, Opcode_Letast_Binding, Get_Cdr(Bindings), Envir, Get_Car(Get_Car(Bindings)));
|
|
|
|
Pop_Tops (Interp, 2);
|
|
end if;
|
|
end Evaluate_Letast_Syntax;
|
|
|
|
procedure Evaluate_Letrec_Syntax is
|
|
pragma Inline (Evaluate_Letrec_Syntax);
|
|
Synlist: Object_Pointer;
|
|
Envir: Object_Pointer;
|
|
Bindings: aliased Object_Pointer;
|
|
begin
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "let".
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
Check_Let_Syntax;
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
-- Switch the frame to Opcode_Grouped_Call and let its environment
|
|
-- be the new environment created. Use Reload_Frame() instead
|
|
-- of Switch_Frame() for continuation. This frame is executed once
|
|
-- the Opcode_Letrec_Binding frame pushed in the 'if' block is finished.
|
|
Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(Operand)); -- <test>
|
|
|
|
-- Create a new environment over the current environment.
|
|
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
|
|
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment
|
|
|
|
Bindings := Get_Car(Operand); -- <bindings>
|
|
if Bindings /= Nil_Pointer then
|
|
-- <bindings> is not empty
|
|
|
|
Push_Top (Interp, Bindings'Unchecked_Access);
|
|
-- Say, <bindings> is ((x 2) (y 2)).
|
|
-- Get_Car(Bindings) is (x 2).
|
|
-- To get x, Get_Car(Get_Car(Bindings))
|
|
-- To get 2, Get_Car(Get_Cdr(Get_Car(Bindings)))
|
|
|
|
-- Arrange to evaluate the first <binding> expression in the parent environment.
|
|
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Bindings))));
|
|
|
|
-- Arrange to perform actual binding. Pass the <binding> name as an intermediate
|
|
-- and the next remaing <binding> list as an operand.
|
|
Push_Subframe_With_Intermediate (Interp, Opcode_Letrec_Binding, Get_Cdr(Bindings), Get_Car(Get_Car(Bindings)));
|
|
|
|
Pop_Tops (Interp, 1);
|
|
end if;
|
|
end Evaluate_Letrec_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
procedure Evaluate_Quasiquote_Syntax is
|
|
pragma Inline (Evaluate_Quasiquote_Syntax);
|
|
begin
|
|
Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
|
|
raise Evaluation_Error;
|
|
end Evaluate_Quasiquote_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_Quote_Syntax is
|
|
pragma Inline (Evaluate_Quote_Syntax);
|
|
Synlist: Object_Pointer;
|
|
begin
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "quote". Get the first argument.
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
|
|
if not Is_Cons(Operand) then
|
|
-- e.g) (quote)
|
|
-- (quote . 10)
|
|
Ada.Text_IO.Put_LINE ("TOO FEW ARGUMETNS FOR QUOTE");
|
|
raise Syntax_Error;
|
|
elsif Get_Cdr(Operand) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR QUOTE");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
Return_Frame (Interp, Get_Car(Operand));
|
|
end Evaluate_Quote_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_Set_Syntax is
|
|
pragma Inline (Evaluate_Set_Syntax);
|
|
Synlist: Object_Pointer;
|
|
begin
|
|
-- (set! <variable> <expression>)
|
|
-- e.g) (set! x 10)
|
|
|
|
Synlist := Operand;
|
|
Operand := Get_Cdr(Operand); -- Skip "set!"
|
|
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Synlist.Flags and Syntax_Checked) = 0 then
|
|
if not Is_Cons(Operand) or else not Is_Cons(Get_Cdr(Operand)) then
|
|
-- e.g) (set!)
|
|
-- (set . 10)
|
|
-- (set x . 10)
|
|
Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR SET!");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if not Is_Symbol(Get_Car(Operand)) then -- <variable>
|
|
Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if Get_Cdr(Get_Cdr(Operand)) /= Nil_Pointer then
|
|
-- (set x 10 20)
|
|
-- (set x 10 . 20)
|
|
Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR SET!");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Synlist.Flags := Synlist.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Operand)), Nil_Pointer); -- <expression>
|
|
Push_Subframe (Interp, Opcode_Set_Finish, Get_Car(Operand)); -- <variable>
|
|
end Evaluate_Set_Syntax;
|
|
|
|
-- ----------------------------------------------------------------
|
|
|
|
procedure Evaluate_List is
|
|
Ptr: Object_Pointer;
|
|
begin
|
|
Ptr := Get_Car(Operand);
|
|
if Is_Syntax(Ptr) then
|
|
-- special syntax symbol. normal evaluation rule doesn't
|
|
-- apply for special syntax objects.
|
|
|
|
case Ptr.Scode is
|
|
when And_Syntax =>
|
|
Evaluate_And_Syntax;
|
|
|
|
when Begin_Syntax =>
|
|
Evaluate_Begin_Syntax;
|
|
|
|
when Case_Syntax =>
|
|
Evaluate_Case_Syntax;
|
|
|
|
when Cond_Syntax =>
|
|
Evaluate_Cond_Syntax;
|
|
|
|
when Define_Syntax =>
|
|
Evaluate_Define_Syntax;
|
|
|
|
when Do_Syntax =>
|
|
Evaluate_Do_Syntax;
|
|
|
|
when If_Syntax =>
|
|
Evaluate_If_Syntax;
|
|
|
|
when Lambda_Syntax =>
|
|
Evaluate_Lambda_Syntax;
|
|
|
|
when Let_Syntax =>
|
|
Evaluate_Let_Syntax;
|
|
|
|
when Letast_Syntax =>
|
|
Evaluate_Letast_Syntax;
|
|
|
|
when Letrec_Syntax =>
|
|
Evaluate_Letrec_Syntax;
|
|
|
|
when Or_Syntax =>
|
|
Evaluate_Or_Syntax;
|
|
|
|
when Quasiquote_Syntax =>
|
|
Evaluate_Quasiquote_Syntax;
|
|
|
|
when Quote_Syntax =>
|
|
Evaluate_Quote_Syntax;
|
|
|
|
when Set_Syntax => -- set!
|
|
Evaluate_Set_Syntax;
|
|
|
|
end case;
|
|
else
|
|
-- procedure call
|
|
-- (<operator> <operand1> ...)
|
|
if (Interp.State and Force_Syntax_Check) /= 0 or else
|
|
(Operand.Flags and Syntax_Checked) = 0 then
|
|
|
|
if Get_Last_Cdr(Operand) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("ERROR: FUCKING CDR FOR PROCEDURE CALL.$$$$");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Operand.Flags := Operand.Flags or Syntax_Checked;
|
|
end if;
|
|
|
|
-- Switch the current frame to evaluate <operator>
|
|
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Ptr, Nil_Pointer);
|
|
-- Push a new frame to evaluate arguments.
|
|
Push_Subframe (Interp, Opcode_Procedure_Call, Get_Cdr(Operand));
|
|
end if;
|
|
end Evaluate_List;
|
|
|
|
begin
|
|
Push_Top (Interp, Operand'Unchecked_Access);
|
|
|
|
Operand := Get_Frame_Operand(Interp.Stack);
|
|
|
|
declare
|
|
f: object_word;
|
|
for f'address use interp.stack'address;
|
|
o: object_word;
|
|
for o'address use operand'address;
|
|
begin
|
|
ada.text_io.put ("Frame" & object_word'image(f) & " EVALUATE OPERAND" & object_word'image(o) & " ");
|
|
print (interp, operand);
|
|
ada.text_io.put (" CURRENT RESULT ");
|
|
print (interp, get_Frame_result(interp.stack));
|
|
end;
|
|
|
|
if not Is_Normal_Pointer(Operand) then
|
|
-- integer, character, specal pointers
|
|
-- TODO: some normal pointers may point to literal objects. e.g.) bignum
|
|
goto Literal;
|
|
end if;
|
|
|
|
case Operand.Tag is
|
|
when Symbol_Object => -- Is_Symbol(Operand)
|
|
-- TODO: find it in the Environment hierarchy.. not in the current environemnt.
|
|
declare
|
|
Ptr: Object_Pointer;
|
|
begin
|
|
Ptr := Get_Environment (Interp.Self, Operand);
|
|
if Ptr = null then
|
|
-- unbound
|
|
Ada.Text_IO.Put_Line ("Unbound symbol....");
|
|
Print (Interp, Operand);
|
|
raise Evaluation_Error;
|
|
else
|
|
-- symbol found in the environment
|
|
Operand := Ptr;
|
|
goto Literal; -- In fact, this is not a literal, but can be handled in the same way
|
|
end if;
|
|
end;
|
|
|
|
when Cons_Object => -- Is_Cons(Operand)
|
|
-- ( ... )
|
|
Evaluate_List;
|
|
|
|
when others =>
|
|
-- normal literal object
|
|
goto Literal;
|
|
end case;
|
|
goto Done;
|
|
|
|
<<Literal>>
|
|
Return_Frame (Interp, Operand);
|
|
goto Done;
|
|
|
|
<<Done>>
|
|
Pop_Tops (Interp, 1);
|
|
end Evaluate;
|