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

implemented let*

Browse Source
This commit is contained in:
hyung-hwan 2014-01-24 07:58:46 +00:00
parent acad93d2cf
commit bf60a7d3ff
3 changed files with 135 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -220,8 +220,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end; end;
end Evaluate_Lambda_Syntax; end Evaluate_Lambda_Syntax;
procedure Evaluate_Let_Syntax is procedure Check_Let_Syntax is
pragma Inline (Evaluate_Let_Syntax); pragma Inline (Check_Let_Syntax);
Bindings: Object_Pointer; Bindings: Object_Pointer;
LetBody: Object_Pointer; LetBody: Object_Pointer;
@ -236,7 +236,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if; end if;
Bindings := Get_Car(Operand); -- <bindings> Bindings := Get_Car(Operand); -- <bindings>
if not Is_Cons(Bindings) then if Bindings /= Nil_Pointer and then not Is_Cons(Bindings) then
Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET"); Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
@ -249,70 +249,103 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Cdr := Bindings; if Is_Cons(Bindings) then
loop Cdr := Bindings;
Car := Get_Car(Cdr); -- <binding> loop
if not Is_Cons(Car) or else not Is_Cons(Get_Cdr(Car)) or else Get_Cdr(Get_Cdr(Car)) /= Nil_Pointer then Car := Get_Car(Cdr); -- <binding>
-- no binding name or no binding value or garbage after that if not Is_Cons(Car) or else not Is_Cons(Get_Cdr(Car)) or else Get_Cdr(Get_Cdr(Car)) /= Nil_Pointer then
Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET"); -- no binding name or no binding value or garbage after that
raise Syntax_Error; Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET");
end if; raise Syntax_Error;
end if;
if not Is_Symbol(Get_Car(Car)) then if not Is_Symbol(Get_Car(Car)) 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 declare
V: Object_Pointer; V: Object_Pointer;
begin begin
V := Bindings; V := Bindings;
loop loop
exit when V = Cdr; exit when V = Cdr;
if Get_Car(Get_Car(V)) = Get_Car(Car) then 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;
V := Get_Cdr(V); V := Get_Cdr(V);
end loop; end loop;
end; end;
-- Move on to the next binding -- Move on to the next binding
Cdr := Get_Cdr(Cdr); Cdr := Get_Cdr(Cdr);
exit when not Is_Cons(Cdr); exit when not Is_Cons(Cdr);
end loop; end loop;
if Cdr /= Nil_Pointer then if Cdr /= 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 if;
-- To avoid problems of temporary object pointer problems. -- To avoid problems of temporary object pointer problems.
Car := Bindings; Car := Bindings;
Cdr := LetBody; Cdr := LetBody;
end Check_Let_Syntax;
procedure Evaluate_Let_Syntax is
pragma Inline (Evaluate_Let_Syntax);
begin
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
Set_Frame_Operand (Interp.Stack, Cdr); Set_Frame_Operand (Interp.Stack, Cdr);
Push_Frame (Interp, Opcode_Let_Binding, Car); Interp.Environment := Make_Environment(Interp.Self, Interp.Environment);
Push_Frame (Interp, Opcode_Let_Evaluation, Car); Set_Frame_Environment (Interp.Stack, Interp.Environment);
-- Some let samples:
-- #1.
-- (define x 99)
-- (let () (define x 100)) ; no actual bindings
-- x ; this must be 99
--
-- #2.
-- ...
if Car /= Nil_Pointer then
-- <bindings> is not empty
Push_Frame (Interp, Opcode_Let_Binding, Car);
Push_Frame (Interp, Opcode_Let_Evaluation, Car);
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);
begin begin
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
--Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); -- Letast_Binding must see this new environment
--Set_Frame_Operand (Interp.Stack, Cdr); -- and must make the binding in this environment.
Interp.Environment := Make_Environment(Interp.Self, Interp.Environment);
--Push_Frame (Interp, Opcode_Let_Binding, Car); -- Body evaluation can be done the same way as normal let.
--Push_Frame (Interp, Opcode_Let_Evaluation, Car); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
null; Set_Frame_Operand (Interp.Stack, Cdr);
-- but in the environment pushed above.
Set_Frame_Environment (Interp.Stack, Interp.Environment);
if Car /= Nil_Pointer then
-- <bindings> is not empty
Push_Frame (Interp, Opcode_Letast_Binding, Car);
end if;
end Evaluate_Letast_Syntax; end Evaluate_Letast_Syntax;
procedure Evaluate_Quote_Syntax is procedure Evaluate_Quote_Syntax is

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

@ -212,19 +212,11 @@ procedure Execute (Interp: in out Interpreter_Record) is
Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access);
-- Evaluation of <bindings> is completed.
-- Update the environments.
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
Y := Reverse_Cons(Get_Frame_Result(Interp.Stack)); Y := Reverse_Cons(Get_Frame_Result(Interp.Stack));
pragma Assert (Interp.Environment = Get_Frame_Environment(Interp.Stack));
-- Push a new environment
Interp.Environment := Make_Environment(Interp.Self, Interp.Environment);
-- Change the frame's environment so that Pop_Frame() doesn't
-- restore the environment to the old one. The new environment
-- has been just pushed above after binding evaluation.
Set_Frame_Environment (Interp.Stack, Interp.Environment);
while Is_Cons(X) loop while Is_Cons(X) loop
pragma Assert (Is_Cons(Y)); pragma Assert (Is_Cons(Y));
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y)); Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
@ -234,10 +226,44 @@ procedure Execute (Interp: in out Interpreter_Record) is
end loop; end loop;
Pop_Frame (Interp); -- done. Pop_Frame (Interp); -- done.
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Do_Let_Binding; end Do_Let_Binding;
procedure Do_Letast_Binding is
pragma Inline (Do_Letast_Binding);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
Y := Get_Frame_Result(Interp.Stack);
if Y = Nil_Pointer then
-- First call
pragma Assert (Is_Cons(X)); -- Don't provoke this procedure if <bindings> is empty.
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
else
-- Subsequence calls
-- Update the environment while evaluating <bindings>
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
X := Get_Cdr(X); -- next binding
if Is_Cons(X) then
-- More bingings to evaluate
Set_Frame_Operand (Interp.Stack, X);
Clear_Frame_Result (Interp.Stack);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
else
-- No more bingings left
Pop_Frame (Interp); -- Done
end if;
end if;
Pop_Tops (Interp, 2);
end Do_Letast_Binding;
procedure Do_Let_Finish is procedure Do_Let_Finish is
pragma Inline (Do_Let_Finish); pragma Inline (Do_Let_Finish);
begin begin
@ -913,14 +939,13 @@ begin
when Opcode_Let_Binding => when Opcode_Let_Binding =>
Do_Let_Binding; Do_Let_Binding;
when Opcode_Letast_Binding =>
Do_Letast_Binding;
when Opcode_Let_Evaluation => when Opcode_Let_Evaluation =>
Do_Let_Evaluation; Do_Let_Evaluation;
when Opcode_Let_Finish => when Opcode_Let_Finish =>
Do_Let_Finish; Do_Let_Finish;
--when Opcode_Finish_Letast_Syntax =>
--when Opcode_Finish_Letrec_Syntax =>
when Opcode_Finish_Or_Syntax => when Opcode_Finish_Or_Syntax =>
Finish_Or_Syntax; -- Conditional Finish_Or_Syntax; -- Conditional

26
lib/h2-scheme.adb
View File

@ -79,8 +79,7 @@ package body H2.Scheme is
-- INTERNALLY-USED TYPES -- INTERNALLY-USED TYPES
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
type Heap_Element_Pointer is access all Heap_Element; type Heap_Element_Pointer is access all Heap_Element;
for Heap_Element_Pointer'Size use Object_Pointer_Bits; -- ensure that it can be overlayed by an ObjectPointer for Heap_Element_Pointer'Size use Object_Pointer_Bits; -- ensure that it can be overlaid by an ObjectPointer
type Thin_Heap_Element_Array is array (1 .. Heap_Size'Last) of Heap_Element; type Thin_Heap_Element_Array is array (1 .. Heap_Size'Last) of Heap_Element;
type Thin_Heap_Element_Array_Pointer is access all Thin_Heap_Element_Array; type Thin_Heap_Element_Array_Pointer is access all Thin_Heap_Element_Array;
@ -88,7 +87,7 @@ package body H2.Scheme is
subtype Moved_Object_Record is Object_Record (Moved_Object, 0); subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
subtype Opcode_Type is Object_Integer range 0 .. 18; subtype Opcode_Type is Object_Integer range 0 .. 19;
Opcode_Exit: constant Opcode_Type := Opcode_Type'(0); Opcode_Exit: constant Opcode_Type := Opcode_Type'(0);
Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1); Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2); Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2);
@ -100,16 +99,17 @@ package body H2.Scheme is
Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(8); Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(8);
Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(9); Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(9);
Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(10); Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(10);
Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(11); Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(11);
Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(12);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(12); Opcode_Apply: constant Opcode_Type := Opcode_Type'(13);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(13); Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(14);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(14); Opcode_Read_List: constant Opcode_Type := Opcode_Type'(15);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(15); Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(16);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(16); Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(17);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(17); Opcode_Close_List: constant Opcode_Type := Opcode_Type'(18);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(18); Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(19);
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- COMMON OBJECTS -- COMMON OBJECTS
@ -1650,7 +1650,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Dummy := Make_Syntax (Interp.Self, Lambda_Syntax, Label_Lambda); -- "lamba" Dummy := Make_Syntax (Interp.Self, Lambda_Syntax, Label_Lambda); -- "lamba"
Dummy := Make_Syntax (Interp.Self, Let_Syntax, Label_Let); -- "let" Dummy := Make_Syntax (Interp.Self, Let_Syntax, Label_Let); -- "let"
Dummy := Make_Syntax (Interp.Self, Letast_Syntax, Label_Letast); -- "let*" Dummy := Make_Syntax (Interp.Self, Letast_Syntax, Label_Letast); -- "let*"
Dummy := Make_Syntax (Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrc" Dummy := Make_Syntax (Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrec"
Dummy := Make_Syntax (Interp.Self, Or_Syntax, Label_Or); -- "or" Dummy := Make_Syntax (Interp.Self, Or_Syntax, Label_Or); -- "or"
Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote" Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote"
Interp.Symbol.Quasiquote := Make_Syntax (Interp.Self, Quasiquote_Syntax, Label_Quasiquote); -- "quasiquote" Interp.Symbol.Quasiquote := Make_Syntax (Interp.Self, Quasiquote_Syntax, Label_Quasiquote); -- "quasiquote"