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

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

@ -220,8 +220,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end;
end Evaluate_Lambda_Syntax;
procedure Evaluate_Let_Syntax is
pragma Inline (Evaluate_Let_Syntax);
procedure Check_Let_Syntax is
pragma Inline (Check_Let_Syntax);
Bindings: Object_Pointer;
LetBody: Object_Pointer;
@ -236,7 +236,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if;
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");
raise Syntax_Error;
end if;
@ -249,70 +249,103 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error;
end if;
Cdr := Bindings;
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
-- 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
Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET");
raise Syntax_Error;
end if;
-- Check for a duplicate binding name
if Is_Cons(Bindings) then
Cdr := Bindings;
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
-- 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
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
Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET");
raise Syntax_Error;
end if;
V := Get_Cdr(V);
end loop;
end;
declare
V: Object_Pointer;
begin
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");
raise Syntax_Error;
end if;
V := Get_Cdr(V);
end loop;
end;
-- Move on to the next binding
Cdr := Get_Cdr(Cdr);
exit when not Is_Cons(Cdr);
end loop;
if Cdr /= Nil_Pointer then
-- The last cdr is not nil.
Ada.Text_IO.Put_Line ("FUCKING CDR FOR LET BINDING");
raise Syntax_Error;
end if;
Cdr := Get_Cdr(Cdr);
exit when not Is_Cons(Cdr);
end loop;
if Cdr /= 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 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);
begin
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
Set_Frame_Operand (Interp.Stack, Cdr);
Push_Frame (Interp, Opcode_Let_Binding, Car);
Push_Frame (Interp, Opcode_Let_Evaluation, Car);
Interp.Environment := Make_Environment(Interp.Self, Interp.Environment);
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;
procedure Evaluate_Letast_Syntax is
pragma Inline (Evaluate_Letast_Syntax);
begin
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
--Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
--Set_Frame_Operand (Interp.Stack, Cdr);
-- Letast_Binding must see this new environment
-- and must make the binding in this environment.
Interp.Environment := Make_Environment(Interp.Self, Interp.Environment);
--Push_Frame (Interp, Opcode_Let_Binding, Car);
--Push_Frame (Interp, Opcode_Let_Evaluation, Car);
null;
-- Body evaluation can be done the same way as normal let.
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
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;
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, Y'Unchecked_Access);
-- Evaluation of <bindings> is completed.
-- Update the environments.
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
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
pragma Assert (Is_Cons(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;
Pop_Frame (Interp); -- done.
Pop_Tops (Interp, 2);
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
pragma Inline (Do_Let_Finish);
begin
@ -913,14 +939,13 @@ begin
when Opcode_Let_Binding =>
Do_Let_Binding;
when Opcode_Letast_Binding =>
Do_Letast_Binding;
when Opcode_Let_Evaluation =>
Do_Let_Evaluation;
when Opcode_Let_Finish =>
Do_Let_Finish;
--when Opcode_Finish_Letast_Syntax =>
--when Opcode_Finish_Letrec_Syntax =>
when Opcode_Finish_Or_Syntax =>
Finish_Or_Syntax; -- Conditional

26
lib/h2-scheme.adb
View File

@ -79,8 +79,7 @@ package body H2.Scheme is
-- INTERNALLY-USED TYPES
-----------------------------------------------------------------------------
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_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 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_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
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_Let_Binding: constant Opcode_Type := Opcode_Type'(9);
Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(10);
Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(11);
Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(10);
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_Read_Object: constant Opcode_Type := Opcode_Type'(13);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(14);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(15);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(16);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(17);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(18);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(13);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(14);
Opcode_Read_List: 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'(17);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(18);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(19);
-----------------------------------------------------------------------------
-- 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, Let_Syntax, Label_Let); -- "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"
Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote"
Interp.Symbol.Quasiquote := Make_Syntax (Interp.Self, Quasiquote_Syntax, Label_Quasiquote); -- "quasiquote"