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

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

@ -4,8 +4,6 @@ procedure Evaluate is
--pragma Inline (Evaluate); --pragma Inline (Evaluate);
Operand: aliased Object_Pointer; 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 1 2 'c '(f g)) ==> (f g)
-- (and) ==> #t -- (and) ==> #t
Operand := Cdr; -- Skip "And" Operand := Get_Cdr(Operand); -- Skip "And"
if Operand = Nil_Pointer then if Operand = Nil_Pointer then
-- (and) -- (and)
Return_Frame (Interp, Result); Return_Frame (Interp, Result);
@ -45,49 +43,33 @@ procedure Evaluate is
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
procedure Evaluate_Define_Syntax is procedure Evaluate_Begin_Syntax is
pragma Inline (Evaluate_Define_Syntax); pragma Inline (Evaluate_Begin_Syntax);
Synlist: Object_Pointer;
begin begin
-- TODO: limit the context where define can be used. Synlist := Operand;
Operand := Get_Cdr(Operand); -- Skip "begin"
-- (define x 10) if (Interp.State and Force_Syntax_Check) /= 0 or else
-- (define (add x y) (+ x y)) -> (define add (lambda (x y) (+ x y))) (Synlist.Flags and Syntax_Checked) = 0 then
Operand := Cdr; -- Skip "define"
if not Is_Cons(Operand) or else not Is_Cons(Get_Cdr(Operand)) then if Operand /= Nil_Pointer and then
-- e.g) (define) Get_Last_Cdr(Operand) /= Nil_Pointer then
-- (define . 10) Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
-- (define x . 10)
Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR DEFINE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Car := Get_Car(Operand); Synlist.Flags := Synlist.Flags or Syntax_Checked;
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;
end if; end if;
Cdr := Get_Car(Cdr); -- Value
-- Arrange to finish defining after value evaluation if Operand = Nil_Pointer then
-- and to evaluate the value part. -- (begin)
--Switch_Frame (Interp.Stack, Opccode_Define_Finish, Car); -- Return nil to the upper frame for (begin).
--Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); Return_Frame (Interp, Nil_Pointer);
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr, Nil_Pointer);
Push_Subframe (Interp, Opcode_Define_Finish, Car);
else else
Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE"); Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Operand, Nil_Pointer);
raise Syntax_Error;
end if; end if;
end Evaluate_Define_Syntax; end Evaluate_Begin_Syntax;
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
procedure Evaluate_Case_Syntax is procedure Evaluate_Case_Syntax is
@ -101,7 +83,7 @@ raise Syntax_Error;
procedure Evaluate_Cond_Syntax is procedure Evaluate_Cond_Syntax is
pragma Inline (Evaluate_Cond_Syntax); pragma Inline (Evaluate_Cond_Syntax);
Ptr: Object_Pointer; Synlist: Object_Pointer;
begin begin
-- cond <clause 1> <clause 2> ... -- cond <clause 1> <clause 2> ...
-- A clause should be of the form: -- A clause should be of the form:
@ -115,7 +97,11 @@ raise Syntax_Error;
-- ((< 3 3) 'less) -- ((< 3 3) 'less)
-- (else 'equal)) => equal -- (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 if Not Is_Cons(Operand) then
-- e.g) (cond) -- e.g) (cond)
-- (cond . 10) -- (cond . 10)
@ -123,34 +109,99 @@ raise Syntax_Error;
raise Syntax_Error; raise Syntax_Error;
end if; end if;
-- Check clauses declare
-- TODO: Skip this check of clauses that have been checked previously. Ptr1: Object_Pointer := Operand;
Ptr := Operand; Ptr2: Object_Pointer;
begin
loop loop
Car := Get_Car(Ptr); -- <clause> Ptr2 := Get_Car(Ptr1); -- <clause>
if not Is_Cons(Car) then if not Is_Cons(Ptr2) then
Ada.Text_IO.Put_Line ("FUCKING CLAUSE FOR COND"); Ada.Text_IO.Put_Line ("FUCKING CLAUSE FOR COND");
raise Syntax_Error; raise Syntax_Error;
end if; 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"); Ada.Text_IO.Put_Line ("FUCKING CDR FOR COND CLAUSE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Ptr := Get_Cdr(Ptr); Ptr1 := Get_Cdr(Ptr1); -- next <clause> list
exit when not Is_Cons(Ptr); exit when not Is_Cons(Ptr1);
end loop; end loop;
if Ptr /= Nil_Pointer then if Ptr1 /= Nil_Pointer then
Ada.Text_IO.Put_Line ("FUCKING LAST CLAUSE FOR COND"); Ada.Text_IO.Put_Line ("FUCKING LAST CLAUSE FOR COND");
raise Syntax_Error; raise Syntax_Error;
end if; 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> 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); Push_Subframe (Interp, Opcode_Cond_Finish, Operand); -- <clause> list
end Evaluate_Cond_Syntax; 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 procedure Evaluate_Do_Syntax is
pragma Inline (Evaluate_Do_Syntax); pragma Inline (Evaluate_Do_Syntax);
begin begin
@ -162,65 +213,79 @@ raise Syntax_Error;
procedure Evaluate_If_Syntax is procedure Evaluate_If_Syntax is
pragma Inline (Evaluate_If_Syntax); pragma Inline (Evaluate_If_Syntax);
Synlist: Object_Pointer;
begin begin
-- (if <test> <consequent>) -- (if <test> <consequent>)
-- (if <test> <consequent> <alternate>) -- (if <test> <consequent> <alternate>)
-- e.g) (if (> 3 2) 'yes) -- e.g) (if (> 3 2) 'yes)
-- (if (> 3 2) 'yes 'no) -- (if (> 3 2) 'yes 'no)
-- (if (> 3 2) (- 3 2) (+ 3 2)) -- (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) -- e.g) (if)
-- (if . 10) -- (if . 10)
Ada.Text_IO.Put_LINE ("NO CONDITIONAL FOR IF"); Ada.Text_IO.Put_LINE ("NO CONDITIONAL FOR IF");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Car := Get_Car(Operand); -- <test> Ptr := Get_Cdr(Ptr); -- cons cell containg <consequent>
if not Is_Cons(Ptr) then
Operand := Get_Cdr(Operand); -- cons cell containg <consequent> Ada.Text_IO.Put_Line ("NO CONSEQUENT FOR IF");
if not Is_Cons(Operand) then
Ada.Text_IO.Put_Line ("NO ACTION FOR IF");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Cdr := Get_Cdr(Operand); -- cons cell containing <alternate> Ptr := Get_Cdr(Ptr); -- cons cell containing <alternate>
if Cdr = Nil_Pointer then if Ptr = Nil_Pointer then
-- no <alternate>. it's ok -- no <alternate>. it's ok
Ada.Text_IO.Put_Line ("NO ALTERNATE");
null; null;
elsif not Is_Cons(Cdr) then elsif not Is_Cons(Ptr) then
-- no <alternate> but reduncant cdr. -- no <alternate> but reduncant cdr.
-- (if (> 3 2) 3 . 99) -- (if (> 3 2) 3 . 99)
Ada.Text_IO.Put_Line ("FUCKING CDR FOR IF"); Ada.Text_IO.Put_Line ("FUCKING CDR FOR IF");
raise Syntax_Error; 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)
-- (if (> 3 2) 3 2 99) -- (if (> 3 2) 3 2 99)
Ada.Text_IO.Put_Line ("TOO MANY ARGUMENTS FOR IF"); Ada.Text_IO.Put_Line ("TOO MANY ARGUMENTS FOR IF");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
end;
Synlist.Flags := Synlist.Flags or Syntax_Checked;
end if;
-- Arrange to evaluate <consequent> or <alternate> after <test> -- Arrange to evaluate <consequent> or <alternate> after <test>
-- evaluation and to evaluate <test>. Use Switch_Frame/Push_Subframe -- evaluation and to evaluate <test>. Use Switch_Frame/Push_Subframe
-- instead of Switch_Frame/Push_Frame for continuation to work. -- instead of Switch_Frame/Push_Frame for continuation to work.
--Switch_Frame (Interp.Stack, Opcode_If_Finish, Operand, Nil_Pointer); Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- <test>
--Push_Frame (Interp, Opcode_Evaluate_Object, Car); Push_Subframe (Interp, Opcode_If_Finish, Get_Cdr(Operand)); -- <consequent> and later
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer);
Push_Subframe (Interp, Opcode_If_Finish, Operand);
end Evaluate_If_Syntax; end Evaluate_If_Syntax;
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
procedure Evaluate_Lambda_Syntax is procedure Evaluate_Lambda_Syntax is
pragma Inline (Evaluate_Lambda_Syntax); pragma Inline (Evaluate_Lambda_Syntax);
Synlist: Object_Pointer;
begin begin
-- (lambda <formals> <body>) -- (lambda <formals> <body>)
-- e.g) (lambda (x y) (+ x y)) -- e.g) (lambda (x y) (+ x y))
-- e.g) (lambda (x y . z) z) -- e.g) (lambda (x y . z) z)
-- e.g) (lambda x (car x)) -- 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 if not Is_Cons(Operand) then
-- e.g) (lambda) -- e.g) (lambda)
-- (lambda . 10) -- (lambda . 10)
@ -228,45 +293,44 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Car := Get_Car(Operand); -- <formals> declare
if Car = Nil_Pointer or else Is_Symbol(Car) then 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 ...) -- (lambda () ...) or (lambda x ...)
-- nothing to do -- nothing to do
null; null;
elsif Is_Cons(Car) then elsif Is_Cons(Ptr1) then
declare Ptr2 := Ptr1;
Formals: Object_Pointer := Car;
V: Object_Pointer;
begin
Cdr := Formals;
loop loop
Car := Get_Car(Cdr); -- <formal argument> Ptr3 := Get_Car(Ptr2); -- <formal argument>
if not Is_Symbol(Car) then if not Is_Symbol(Ptr3) then
Ada.Text_IO.Put_Line ("WRONG FORMAL FOR LAMBDA"); Ada.Text_IO.Put_Line ("WRONG FORMAL FOR LAMBDA");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
-- Check for a duplication formal argument -- Check for a duplication formal argument
-- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated -- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated
V := Formals; Ptr4 := Ptr1;
loop while Ptr4 /= Ptr2 loop
exit when V = Cdr; if Get_Car(Ptr4) = Ptr3 then
if Get_Car(V) = Car then
Ada.Text_IO.Put_Line ("DUPLICATE FORMAL FOR LAMBDA"); Ada.Text_IO.Put_Line ("DUPLICATE FORMAL FOR LAMBDA");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Ptr4 := Get_Cdr(Ptr4);
V := Get_Cdr(V);
end loop; end loop;
-- Move on to the next formal argument -- Move on to the next formal argument
Cdr := Get_Cdr(Cdr); Ptr2 := Get_Cdr(Ptr2);
exit when not Is_Cons(Cdr); exit when not Is_Cons(Ptr2);
end loop; 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"); Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
@ -275,17 +339,21 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Cdr := Get_Cdr(Operand); -- cons cell containing <body> Ptr1 := Get_Cdr(Operand); -- cons cell containing <body>
if not Is_Cons(Cdr) then if not Is_Cons(Ptr1) then
Ada.Text_IO.Put_Line ("NO BODY"); Ada.Text_IO.Put_Line ("NO BODY");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
if Get_Last_Cdr(Cdr) /= Nil_Pointer then if Get_Last_Cdr(Ptr1) /= Nil_Pointer then
-- (lambda (x y) (+ x y) . 99) -- (lambda (x y) (+ x y) . 99)
Ada.Text_IO.Put_Line ("FUCKING CDR IN BODY FOR LAMBDA"); Ada.Text_IO.Put_Line ("FUCKING CDR IN BODY FOR LAMBDA");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
end;
Synlist.Flags := Synlist.Flags or Syntax_Checked;
end if;
-- Create a closure object and return it the the upper frame. -- Create a closure object and return it the the upper frame.
Return_Frame (Interp, Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack))); 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 procedure Check_Let_Syntax is
pragma Inline (Check_Let_Syntax); pragma Inline (Check_Let_Syntax);
Bindings: Object_Pointer; Bindings: Object_Pointer;
LetBody: Object_Pointer; LetBody: Object_Pointer;
begin begin
-- let <bindings> <body> -- (let <bindings> <body>)
Operand := Cdr; -- Skip "let".
if not Is_Cons(Operand) then if not Is_Cons(Operand) then
-- e.g) (let) -- e.g) (let)
-- (let . 10) -- (let . 10)
@ -324,58 +390,55 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if; end if;
if Is_Cons(Bindings) then if Is_Cons(Bindings) then
Cdr := Bindings; declare
Ptr1: Object_Pointer := Bindings;
Ptr2: Object_Pointer;
Ptr3: Object_Pointer;
begin
loop loop
Car := Get_Car(Cdr); -- <binding> Ptr2 := Get_Car(Ptr1); -- <binding>
if not Is_Cons(Car) or else not Is_Cons(Get_Cdr(Car)) or else Get_Cdr(Get_Cdr(Car)) /= Nil_Pointer then 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 -- no binding name or no binding value or garbage after that
Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET"); Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET");
raise Syntax_Error; raise Syntax_Error;
end if; 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"); Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
-- Check for a duplicate binding name -- Check for a duplicate binding name
-- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated -- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated
declare Ptr3 := Bindings;
V: Object_Pointer; while Ptr3 /= Ptr1 loop
begin if Get_Car(Get_Car(Ptr3)) = Ptr2 then
V := Bindings;
loop
exit when V = Cdr;
if Get_Car(Get_Car(V)) = Get_Car(Car) then
Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET"); Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Ptr3 := Get_Cdr(Ptr3);
V := Get_Cdr(V);
end loop; end loop;
end;
-- Move on to the next binding -- Move on to the next binding
Cdr := Get_Cdr(Cdr); Ptr1 := Get_Cdr(Ptr1);
exit when not Is_Cons(Cdr); exit when not Is_Cons(Ptr1);
end loop; end loop;
if Cdr /= Nil_Pointer then if Ptr1 /= Nil_Pointer then
-- The last cdr is not nil. -- The last cdr is not nil.
Ada.Text_IO.Put_Line ("FUCKING CDR FOR LET BINDING"); Ada.Text_IO.Put_Line ("FUCKING CDR FOR LET BINDING");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
end;
end if; end if;
-- To avoid problems of temporary object pointer problems.
Car := Bindings;
Cdr := LetBody;
end Check_Let_Syntax; end Check_Let_Syntax;
procedure Evaluate_Let_Syntax is procedure Evaluate_Let_Syntax is
pragma Inline (Evaluate_Let_Syntax); pragma Inline (Evaluate_Let_Syntax);
Synlist: Object_Pointer;
Envir: aliased Object_Pointer; Envir: aliased Object_Pointer;
Bindings: aliased Object_Pointer;
begin begin
-- Some let samples: -- Some let samples:
-- #1. -- #1.
@ -393,106 +456,137 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
-- (define x (let ((x x)) x)) -- (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; 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 -- Switch the frame to Opcode_Grouped_Call and let its environment
-- be the new environment created. Use Reload_Frame() instead -- be the new environment created. Use Reload_Frame() instead
-- of Switch_Frame() for continuation. This frame is executed once -- of Switch_Frame() for continuation. This frame is executed once
-- the Opcode_Let_Binding frame pushed in the 'if' block is finished. -- 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. -- Create a new environment over the current environment.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment 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 -- <bindings> is not empty
Push_Top (Interp, Envir'Unchecked_Access); Push_Top (Interp, Envir'Unchecked_Access);
Push_Top (Interp, Bindings'Unchecked_Access);
Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)); Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
-- Say, <bindings> is ((x 2) (y 2)). -- Say, <bindings> is ((x 2) (y 2)).
-- Get_Car(Car) is (x 2). -- Get_Car(Bindings) is (x 2).
-- To get x, Get_Car(Get_Car(Car)) -- To get x, Get_Car(Get_Car(Bindings))
-- To get 2, Get_Car(Get_Cdr(Get_Car(Car))) -- To get 2, Get_Car(Get_Cdr(Get_Car(Bindings)))
-- Arrange to evaluate the first <binding> expression in the parent environment. -- 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 -- Arrange to perform actual binding. Pass the <binding> name as an intermediate
-- and the next remaing <binding> list as an operand. -- 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 if;
end Evaluate_Let_Syntax; end Evaluate_Let_Syntax;
procedure Evaluate_Letast_Syntax is procedure Evaluate_Letast_Syntax is
pragma Inline (Evaluate_Letast_Syntax); pragma Inline (Evaluate_Letast_Syntax);
Synlist: Object_Pointer;
Envir: aliased Object_Pointer; Envir: aliased Object_Pointer;
Bindings: aliased Object_Pointer;
begin begin
Check_Let_Syntax; Synlist := Operand;
-- Car: <bindings>, Cdr: <body> 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. -- Create a new environment over the current environment.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment 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 -- <bindings> is not empty
Push_Top (Interp, Envir'Unchecked_Access); Push_Top (Interp, Envir'Unchecked_Access);
Push_Top (Interp, Bindings'Unchecked_Access);
-- Say, <bindings> is ((x 2) (y 2)). -- Say, <bindings> is ((x 2) (y 2)).
-- Get_Car(Car) is (x 2). -- Get_Car(Bindings) is (x 2).
-- To get x, Get_Car(Get_Car(Car)) -- To get x, Get_Car(Get_Car(Bindings))
-- To get 2, Get_Car(Get_Cdr(Get_Car(Car))) -- To get 2, Get_Car(Get_Cdr(Get_Car(Bindings)))
-- Arrange to evaluate the first <binding> expression in the parent environment. -- 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 -- Arrange to perform actual binding. Pass the <binding> name as an intermediate
-- and the next remaing <binding> list as an operand. -- 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 if;
end Evaluate_Letast_Syntax; end Evaluate_Letast_Syntax;
procedure Evaluate_Letrec_Syntax is procedure Evaluate_Letrec_Syntax is
pragma Inline (Evaluate_Letrec_Syntax); pragma Inline (Evaluate_Letrec_Syntax);
Synlist: Object_Pointer;
Envir: Object_Pointer; Envir: Object_Pointer;
Bindings: aliased Object_Pointer;
begin 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; 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 -- Switch the frame to Opcode_Grouped_Call and let its environment
-- be the new environment created. Use Reload_Frame() instead -- be the new environment created. Use Reload_Frame() instead
-- of Switch_Frame() for continuation. This frame is executed once -- of Switch_Frame() for continuation. This frame is executed once
-- the Opcode_Letrec_Binding frame pushed in the 'if' block is finished. -- 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. -- Create a new environment over the current environment.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment 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 -- <bindings> is not empty
Push_Top (Interp, Bindings'Unchecked_Access);
-- Say, <bindings> is ((x 2) (y 2)). -- Say, <bindings> is ((x 2) (y 2)).
-- Get_Car(Car) is (x 2). -- Get_Car(Bindings) is (x 2).
-- To get x, Get_Car(Get_Car(Car)) -- To get x, Get_Car(Get_Car(Bindings))
-- To get 2, Get_Car(Get_Cdr(Get_Car(Car))) -- To get 2, Get_Car(Get_Cdr(Get_Car(Bindings)))
-- Arrange to evaluate the first <binding> expression in the parent environment. -- 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 -- Arrange to perform actual binding. Pass the <binding> name as an intermediate
-- and the next remaing <binding> list as an operand. -- 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 if;
end Evaluate_Letrec_Syntax; end Evaluate_Letrec_Syntax;
@ -508,17 +602,27 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
procedure Evaluate_Quote_Syntax is procedure Evaluate_Quote_Syntax is
pragma Inline (Evaluate_Quote_Syntax); pragma Inline (Evaluate_Quote_Syntax);
Synlist: Object_Pointer;
begin 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 if not Is_Cons(Operand) then
-- e.g) (quote) -- e.g) (quote)
-- (quote . 10) -- (quote . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR QUOTE"); Ada.Text_IO.Put_LINE ("TOO FEW ARGUMETNS FOR QUOTE");
raise Syntax_Error; raise Syntax_Error;
elsif Get_Cdr(Operand) /= Nil_Pointer then 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; raise Syntax_Error;
end if; end if;
Synlist.Flags := Synlist.Flags or Syntax_Checked;
end if;
Return_Frame (Interp, Get_Car(Operand)); Return_Frame (Interp, Get_Car(Operand));
end Evaluate_Quote_Syntax; end Evaluate_Quote_Syntax;
@ -526,12 +630,16 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
procedure Evaluate_Set_Syntax is procedure Evaluate_Set_Syntax is
pragma Inline (Evaluate_Set_Syntax); pragma Inline (Evaluate_Set_Syntax);
Synlist: Object_Pointer;
begin begin
-- (set! <variable> <expression>) -- (set! <variable> <expression>)
-- e.g) (set! x 10) -- 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 if not Is_Cons(Operand) or else not Is_Cons(Get_Cdr(Operand)) then
-- e.g) (set!) -- e.g) (set!)
-- (set . 10) -- (set . 10)
@ -540,107 +648,41 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Car := Get_Car(Operand); -- <variable> if not Is_Symbol(Get_Car(Operand)) then -- <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
Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!"); Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!");
raise Syntax_Error; raise Syntax_Error;
end if; 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; end Evaluate_Set_Syntax;
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
procedure Evaluate_List is
Ptr: Object_Pointer;
begin begin
Push_Top (Interp, Operand'Unchecked_Access); Ptr := Get_Car(Operand);
Push_Top (Interp, Car'Unchecked_Access); if Is_Syntax(Ptr) then
Push_Top (Interp, Cdr'Unchecked_Access); -- special syntax symbol. normal evaluation rule doesn't
<<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
-- apply for special syntax objects. -- apply for special syntax objects.
case Car.Scode is case Ptr.Scode is
when And_Syntax => when And_Syntax =>
Evaluate_And_Syntax; Evaluate_And_Syntax;
when Begin_Syntax => when Begin_Syntax =>
Operand := Cdr; -- Skip "begin" Evaluate_Begin_Syntax;
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;
when Case_Syntax => when Case_Syntax =>
Evaluate_Case_Syntax; Evaluate_Case_Syntax;
@ -685,17 +727,70 @@ end;
else else
-- procedure call -- procedure call
-- (<operator> <operand1> ...) -- (<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 if Get_Last_Cdr(Operand) /= Nil_Pointer then
Ada.Text_IO.Put_Line ("ERROR: FUCKING CDR FOR PROCEDURE CALL.$$$$"); Ada.Text_IO.Put_Line ("ERROR: FUCKING CDR FOR PROCEDURE CALL.$$$$");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
-- Switch the current frame to evaluate <operator> Operand.Flags := Operand.Flags or Syntax_Checked;
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer);
-- Push a new frame to evaluate arguments.
Push_Subframe (Interp, Opcode_Procedure_Call, Cdr);
end if; 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 => when others =>
-- normal literal object -- normal literal object
goto Literal; goto Literal;
@ -703,16 +798,9 @@ end;
goto Done; goto Done;
<<Literal>> <<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); Return_Frame (Interp, Operand);
goto Done; goto Done;
<<Done>> <<Done>>
Pop_Tops (Interp, 3); Pop_Tops (Interp, 1);
end Evaluate; 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 if Is_Cons(O) then
Reload_Frame (Interp, Opcode_Grouped_Call, O); Reload_Frame (Interp, Opcode_Grouped_Call, O);
else else
Pop_Frame (Interp); Pop_Frame (Interp); -- no <expression> to evaluate
end if; end if;
else else
O := Get_Cdr(O); -- next <clause> list O := Get_Cdr(O); -- next <clause> list
@ -96,7 +96,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
if Is_Cons(O) then if Is_Cons(O) then
Reload_Frame (Interp, Opcode_Grouped_Call, O); Reload_Frame (Interp, Opcode_Grouped_Call, O);
else else
Pop_Frame (Interp); Pop_Frame (Interp); -- no <expression> to evaluate
end if; end if;
else else
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(R), Nil_Pointer); 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; Interp.Self := Aliased_Interp'Unchecked_Access;
end; end;
Interp.State := 0;
Interp.Storage_Pool := Storage_Pool; Interp.Storage_Pool := Storage_Pool;
Interp.Symbol_Table := Nil_Pointer; 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. -- represents the value that can be stored in this field.
type Object_Flags is mod 2 ** 4; type Object_Flags is mod 2 ** 4;
Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#); Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#);
Syntax_Checked: constant Object_Flags := Object_Flags'(2#0010#);
type Syntax_Code is ( type Syntax_Code is (
And_Syntax, And_Syntax,
@ -503,9 +504,13 @@ private
Data: Top_Array(1 .. 100) := (others => null); Data: Top_Array(1 .. 100) := (others => null);
end record; 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 tagged limited record
type Interpreter_Record is limited record type Interpreter_Record is limited record
Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer
State: Interpreter_State := 0; -- Internal housekeeping state
Storage_Pool: Storage_Pool_Pointer := null; Storage_Pool: Storage_Pool_Pointer := null;
Trait: Option_Record(Trait_Option); Trait: Option_Record(Trait_Option);