hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

touched evaluator code

Browse Source
This commit is contained in:
hyung-hwan 2014-02-11 09:35:44 +00:00
parent cbf8d0e54e
commit 9a426594a3
4 changed files with 477 additions and 383 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

586
lib/h2-scheme-execute-evaluate.adb
View File

@ -4,8 +4,6 @@ procedure Evaluate is
--pragma Inline (Evaluate);
Operand: aliased Object_Pointer;
Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer;
-- ----------------------------------------------------------------
@ -23,7 +21,7 @@ procedure Evaluate is
-- (and 1 2 'c '(f g)) ==> (f g)
-- (and) ==> #t
Operand := Cdr; -- Skip "And"
Operand := Get_Cdr(Operand); -- Skip "And"
if Operand = Nil_Pointer then
-- (and)
Return_Frame (Interp, Result);
@ -45,49 +43,33 @@ procedure Evaluate is
-- ----------------------------------------------------------------
procedure Evaluate_Define_Syntax is
pragma Inline (Evaluate_Define_Syntax);
procedure Evaluate_Begin_Syntax is
pragma Inline (Evaluate_Begin_Syntax);
Synlist: Object_Pointer;
begin
-- TODO: limit the context where define can be used.
Synlist := Operand;
Operand := Get_Cdr(Operand); -- Skip "begin"
-- (define x 10)
-- (define (add x y) (+ x y)) -> (define add (lambda (x y) (+ x y)))
Operand := Cdr; -- 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");
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;
Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand);
if Is_Cons(Car) then
-- define a function: (define (add x y) ...)
ada.text_io.put_line ("NOT IMPLEMENTED YET");
raise Syntax_Error;
elsif Is_Symbol(Car) then
-- define a symbol: (define x ...)
if Get_Cdr(Cdr) /= Nil_Pointer then
Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR DEFINE");
raise Syntax_Error;
Synlist.Flags := Synlist.Flags or Syntax_Checked;
end if;
Cdr := Get_Car(Cdr); -- Value
-- Arrange to finish defining after value evaluation
-- and to evaluate the value part.
--Switch_Frame (Interp.Stack, Opccode_Define_Finish, Car);
--Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr, Nil_Pointer);
Push_Subframe (Interp, Opcode_Define_Finish, Car);
if Operand = Nil_Pointer then
-- (begin)
-- Return nil to the upper frame for (begin).
Return_Frame (Interp, Nil_Pointer);
else
Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE");
raise Syntax_Error;
Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Operand, Nil_Pointer);
end if;
end Evaluate_Define_Syntax;
end Evaluate_Begin_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_Case_Syntax is
@ -101,7 +83,7 @@ raise Syntax_Error;
procedure Evaluate_Cond_Syntax is
pragma Inline (Evaluate_Cond_Syntax);
Ptr: Object_Pointer;
Synlist: Object_Pointer;
begin
-- cond <clause 1> <clause 2> ...
-- A clause should be of the form:
@ -115,7 +97,11 @@ raise Syntax_Error;
-- ((< 3 3) 'less)
-- (else 'equal)) => equal
Operand := Cdr; -- Skip "cond"
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)
@ -123,34 +109,99 @@ raise Syntax_Error;
raise Syntax_Error;
end if;
-- Check clauses
-- TODO: Skip this check of clauses that have been checked previously.
Ptr := Operand;
declare
Ptr1: Object_Pointer := Operand;
Ptr2: Object_Pointer;
begin
loop
Car := Get_Car(Ptr); -- <clause>
if not Is_Cons(Car) then
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(Car) /= Nil_Pointer then
If Get_Last_Cdr(Ptr2) /= Nil_Pointer then
Ada.Text_IO.Put_Line ("FUCKING CDR FOR COND CLAUSE");
raise Syntax_Error;
end if;
Ptr := Get_Cdr(Ptr);
exit when not Is_Cons(Ptr);
Ptr1 := Get_Cdr(Ptr1); -- next <clause> list
exit when not Is_Cons(Ptr1);
end loop;
if Ptr /= Nil_Pointer then
if Ptr1 /= Nil_Pointer then
Ada.Text_IO.Put_Line ("FUCKING LAST CLAUSE FOR COND");
raise Syntax_Error;
end if;
end;
Car := Get_Car(Operand); -- first <clause>
Synlist.Flags := Synlist.Flags or Syntax_Checked;
end if;
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Car), Nil_Pointer); -- first <test>
Push_Subframe (Interp, Opcode_Cond_Finish, Operand);
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;
Ptr: Object_Pointer;
begin
-- TODO: limit the context where define can be used.
-- (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;
Ptr := Get_Car(Operand);
if Is_Cons(Ptr) then
ada.text_io.put_line ("NOT IMPLEMENTED YET");
raise Syntax_Error;
elsif Is_Symbol(Ptr) 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;
Ptr := Get_Car(Operand);
if Is_Cons(Ptr) then
-- define a function: (define (add x y) ...)
ada.text_io.put_line ("NOT IMPLEMENTED YET");
raise Syntax_Error;
else
-- define a symbol: (define x ...)
pragma Assert (Is_Symbol(Ptr));
-- Arrange to finish defining after value evaluation
-- and to evaluate the value part.
--Switch_Frame (Interp.Stack, Opccode_Define_Finish, Ptr);
--Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Operand)));
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Operand)), Nil_Pointer);
Push_Subframe (Interp, Opcode_Define_Finish, Ptr);
end if;
end Evaluate_Define_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_Do_Syntax is
pragma Inline (Evaluate_Do_Syntax);
begin
@ -162,65 +213,79 @@ raise Syntax_Error;
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))
Operand := Cdr; -- Skip "if"
if Not Is_Cons(Operand) then
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;
Car := Get_Car(Operand); -- <test>
Operand := Get_Cdr(Operand); -- cons cell containg <consequent>
if not Is_Cons(Operand) then
Ada.Text_IO.Put_Line ("NO ACTION FOR 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;
Cdr := Get_Cdr(Operand); -- cons cell containing <alternate>
if Cdr = Nil_Pointer then
Ptr := Get_Cdr(Ptr); -- cons cell containing <alternate>
if Ptr = Nil_Pointer then
-- no <alternate>. it's ok
Ada.Text_IO.Put_Line ("NO ALTERNATE");
null;
elsif not Is_Cons(Cdr) then
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(Cdr) /= Nil_Pointer then
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_If_Finish, Operand, Nil_Pointer);
--Push_Frame (Interp, Opcode_Evaluate_Object, Car);
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer);
Push_Subframe (Interp, Opcode_If_Finish, Operand);
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))
Operand := Cdr; -- Skip "lambda". cons cell pointing to <formals>
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)
@ -228,45 +293,44 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error;
end if;
Car := Get_Car(Operand); -- <formals>
if Car = Nil_Pointer or else Is_Symbol(Car) then
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(Car) then
declare
Formals: Object_Pointer := Car;
V: Object_Pointer;
begin
Cdr := Formals;
elsif Is_Cons(Ptr1) then
Ptr2 := Ptr1;
loop
Car := Get_Car(Cdr); -- <formal argument>
if not Is_Symbol(Car) then
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
V := Formals;
loop
exit when V = Cdr;
if Get_Car(V) = Car then
-- 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;
V := Get_Cdr(V);
Ptr4 := Get_Cdr(Ptr4);
end loop;
-- Move on to the next formal argument
Cdr := Get_Cdr(Cdr);
exit when not Is_Cons(Cdr);
Ptr2 := Get_Cdr(Ptr2);
exit when not Is_Cons(Ptr2);
end loop;
end;
if Cdr /= Nil_Pointer and then not Is_Symbol(Cdr) then
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;
@ -275,17 +339,21 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error;
end if;
Cdr := Get_Cdr(Operand); -- cons cell containing <body>
if not Is_Cons(Cdr) then
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(Cdr) /= Nil_Pointer then
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)));
@ -295,12 +363,10 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
procedure Check_Let_Syntax is
pragma Inline (Check_Let_Syntax);
Bindings: Object_Pointer;
LetBody: Object_Pointer;
begin
-- let <bindings> <body>
Operand := Cdr; -- Skip "let".
-- (let <bindings> <body>)
if not Is_Cons(Operand) then
-- e.g) (let)
-- (let . 10)
@ -324,58 +390,55 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if;
if Is_Cons(Bindings) then
Cdr := Bindings;
declare
Ptr1: Object_Pointer := Bindings;
Ptr2: Object_Pointer;
Ptr3: Object_Pointer;
begin
loop
Car := Get_Car(Cdr); -- <binding>
if not Is_Cons(Car) or else not Is_Cons(Get_Cdr(Car)) or else Get_Cdr(Get_Cdr(Car)) /= Nil_Pointer then
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;
if not Is_Symbol(Get_Car(Car)) then
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
declare
V: Object_Pointer;
begin
V := Bindings;
loop
exit when V = Cdr;
if Get_Car(Get_Car(V)) = Get_Car(Car) then
-- 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;
V := Get_Cdr(V);
Ptr3 := Get_Cdr(Ptr3);
end loop;
end;
-- Move on to the next binding
Cdr := Get_Cdr(Cdr);
exit when not Is_Cons(Cdr);
Ptr1 := Get_Cdr(Ptr1);
exit when not Is_Cons(Ptr1);
end loop;
if Cdr /= Nil_Pointer then
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;
-- To avoid problems of temporary object pointer problems.
Car := Bindings;
Cdr := LetBody;
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.
@ -393,106 +456,137 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
-- (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;
-- Car: <bindings>, Cdr: <body>
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, Cdr);
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
if Car /= Nil_Pointer then
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(Car) is (x 2).
-- To get x, Get_Car(Get_Car(Car))
-- To get 2, Get_Car(Get_Cdr(Get_Car(Car)))
-- 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(Car))), Envir);
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(Car), Envir, Get_Car(Get_Car(Car)));
Push_Subframe_With_Environment_And_Intermediate (Interp, Opcode_Let_Binding, Get_Cdr(Bindings), Envir, Get_Car(Get_Car(Bindings)));
Pop_Tops (Interp, 1);
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
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
Synlist := Operand;
Operand := Get_Cdr(Operand); -- Skip "let".
Reload_Frame (Interp, Opcode_Grouped_Call, Cdr);
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
if Car /= Nil_Pointer then
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(Car) is (x 2).
-- To get x, Get_Car(Get_Car(Car))
-- To get 2, Get_Car(Get_Cdr(Get_Car(Car)))
-- 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(Car))), Envir);
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(Car), Envir, Get_Car(Get_Car(Car)));
Push_Subframe_With_Environment_And_Intermediate (Interp, Opcode_Letast_Binding, Get_Cdr(Bindings), Envir, Get_Car(Get_Car(Bindings)));
Pop_Tops (Interp, 1);
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;
-- Car: <bindings>, Cdr: <body>
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, Cdr);
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
if Car /= Nil_Pointer then
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(Car) is (x 2).
-- To get x, Get_Car(Get_Car(Car))
-- To get 2, Get_Car(Get_Cdr(Get_Car(Car)))
-- 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(Car))));
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(Car), Get_Car(Get_Car(Car)));
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;
@ -508,17 +602,27 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
procedure Evaluate_Quote_Syntax is
pragma Inline (Evaluate_Quote_Syntax);
Synlist: Object_Pointer;
begin
Operand := Cdr; -- Skip "quote". Get the first argument.
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 ("FUCKNING CDR FOR QUOTE");
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 ("WRONG NUMBER OF ARGUMENTS FOR QUOTE");
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;
@ -526,12 +630,16 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
procedure Evaluate_Set_Syntax is
pragma Inline (Evaluate_Set_Syntax);
Synlist: Object_Pointer;
begin
-- (set! <variable> <expression>)
-- e.g) (set! x 10)
Operand := Cdr; -- Skip "set!"
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)
@ -540,107 +648,41 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error;
end if;
Car := Get_Car(Operand); -- <variable>
Cdr := Get_Cdr(Operand); -- cons cell to <expression>
if Is_Symbol(Car) then
if Get_Cdr(Cdr) /= Nil_Pointer then
Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR SET!");
raise Syntax_Error;
end if;
Cdr := Get_Car(Cdr); -- <expression>
-- Arrange to finish setting a variable after <expression> evaluation.
--Switch_Frame (Interp.Stack, Opcode_Set_Finish, Car, Nil_Pointer);
-- Arrange to evalaute the value part
--Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
-- These 2 lines derives the same result as the 2 lines commented out above.
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr, Nil_Pointer);
Push_Subframe (Interp, Opcode_Set_Finish, Car);
else
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;
-- ----------------------------------------------------------------
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access);
Push_Top (Interp, Cdr'Unchecked_Access);
<<Start_Over>>
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.
Car := Get_Environment (Interp.Self, Operand);
if Car = null then
-- unbound
Ada.Text_IO.Put_Line ("Unbound symbol....");
Print (Interp, Operand);
raise Evaluation_Error;
else
-- symbol found in the environment
Operand := Car;
goto Literal; -- In fact, this is not a literal, but can be handled in the same way
end if;
when Cons_Object => -- Is_Cons(Operand)
Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand);
if Is_Syntax(Car) then
-- special syntax symbol. normal evaluate rule doesn't
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 Car.Scode is
case Ptr.Scode is
when And_Syntax =>
Evaluate_And_Syntax;
when Begin_Syntax =>
Operand := Cdr; -- Skip "begin"
if Operand = Nil_Pointer then
-- (begin)
-- Return nil to the upper frame for (begin).
Return_Frame (Interp, Nil_Pointer);
else
if Get_Last_Cdr(Operand) /= Nil_Pointer then
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
raise Syntax_Error;
end if;
Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Operand, Nil_Pointer);
end if;
--if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
-- -- I call Evaluate_Group for optimization here.
-- Evaluate_Group; -- for optimization only. not really needed.
-- -- I can jump to Start_Over because Evaluate_Group called
-- -- above pushes an Opcode_Evaluate_Object frame.
-- pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Evaluate_Object);
-- goto Start_Over; -- for optimization only. not really needed.
--end if;
Evaluate_Begin_Syntax;
when Case_Syntax =>
Evaluate_Case_Syntax;
@ -685,17 +727,70 @@ end;
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;
-- Switch the current frame to evaluate <operator>
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer);
-- Push a new frame to evaluate arguments.
Push_Subframe (Interp, Opcode_Procedure_Call, Cdr);
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;
@ -703,16 +798,9 @@ end;
goto Done;
<<Literal>>
declare
w: object_word;
for w'address use operand'address;
begin
Ada.Text_IO.Put ("Return => (" & object_word'image(w) & ") =>" );
Print (Interp, Operand);
end;
Return_Frame (Interp, Operand);
goto Done;
<<Done>>
Pop_Tops (Interp, 3);
Pop_Tops (Interp, 1);
end Evaluate;

4
lib/h2-scheme-execute.adb
View File

@ -80,7 +80,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
if Is_Cons(O) then
Reload_Frame (Interp, Opcode_Grouped_Call, O);
else
Pop_Frame (Interp);
Pop_Frame (Interp); -- no <expression> to evaluate
end if;
else
O := Get_Cdr(O); -- next <clause> list
@ -96,7 +96,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
if Is_Cons(O) then
Reload_Frame (Interp, Opcode_Grouped_Call, O);
else
Pop_Frame (Interp);
Pop_Frame (Interp); -- no <expression> to evaluate
end if;
else
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(R), Nil_Pointer);

1
lib/h2-scheme.adb
View File

@ -1863,6 +1863,7 @@ end if;
Interp.Self := Aliased_Interp'Unchecked_Access;
end;
Interp.State := 0;
Interp.Storage_Pool := Storage_Pool;
Interp.Symbol_Table := Nil_Pointer;

5
lib/h2-scheme.ads
View File

@ -163,6 +163,7 @@ package H2.Scheme is
-- represents the value that can be stored in this field.
type Object_Flags is mod 2 ** 4;
Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#);
Syntax_Checked: constant Object_Flags := Object_Flags'(2#0010#);
type Syntax_Code is (
And_Syntax,
@ -503,9 +504,13 @@ private
Data: Top_Array(1 .. 100) := (others => null);
end record;
type Interpreter_State is mod 2 ** 4;
Force_Syntax_Check: constant Interpreter_State := Interpreter_State'(2#0001#);
--type Interpreter_Record is tagged limited record
type Interpreter_Record is limited record
Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer
State: Interpreter_State := 0; -- Internal housekeeping state
Storage_Pool: Storage_Pool_Pointer := null;
Trait: Option_Record(Trait_Option);