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

added more code for 'do'

Browse Source
This commit is contained in:
hyung-hwan 2014-02-17 15:11:00 +00:00
parent 5cfa32e7d9
commit 07503c4da7
4 changed files with 210 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -355,12 +355,99 @@ procedure Evaluate is
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
procedure Evaluate_Do_Syntax is procedure Check_Do_Syntax is
pragma Inline (Evaluate_Do_Syntax);
Synlist: Object_Pointer;
Ptr1: Object_Pointer; Ptr1: Object_Pointer;
Ptr2: Object_Pointer; Ptr2: Object_Pointer;
Ptr3: Object_Pointer; Ptr3: Object_Pointer;
begin
Ptr1 := Operand; -- <bindings> list
if not Is_Cons(Ptr1) then
-- (do)
-- (do . 10)
Ada.Text_IO.Put_LINE ("NO BIDNIGNS FOR DO");
raise Syntax_Error;
end if;
Ptr2 := Get_Car(Ptr1); -- <bindings>
while Is_Cons(Ptr2) loop
Ptr3 := Get_Car(Ptr2); -- <binding>
if not Is_Cons(Ptr3) then
-- (do (i) (#f))
Ada.Text_IO.Put_Line ("INVALID BINDING FOR DO");
raise Syntax_Error;
end if;
if not Is_Symbol(Get_Car(Ptr3)) then -- <variable>
-- (do ((10 10)) (#f))
Ada.Text_IO.Put_Line ("INVALID BINDING VARIABLE FOR DO");
raise Syntax_Error;
end if;
Ptr3 := Get_Cdr(Ptr3); -- <init> cons
if not Is_Cons(Ptr3) then
-- (do ((i . 10)) (#f))
Ada.Text_IO.Put_Line ("NO INIT IN DO BINDING");
raise Syntax_Error;
end if;
-- Get_Car(Ptr3); -- <init>
Ptr3 := Get_Cdr(Ptr3); -- <step> cons
if Is_Cons(Ptr3) then
-- Get_Car(Ptr3); -- <step>
if Get_Cdr(Ptr3) /= Nil_Pointer then
-- (do ((i 0 10 20)) ... )
Ada.Text_IO.PUT_Line ("TOO MANY STEP EXPRESSIONS IN DO BINDING");
raise Syntax_Error;
end if;
elsif Ptr3 /= Nil_Pointer then
-- (do ((i 0 . 10)) ... )
Ada.Text_IO.Put_Line ("FUCKING CDR in DO BIDNING");
raise Syntax_Error;
end if;
Ptr2 := Get_Cdr(Ptr2);
end loop;
if Ptr2 /= Nil_Pointer then
-- (do 10 . 10)
-- (do 10 (#f))
-- (do ((i 10) (j 20) . 10) (#f))
Ada.Text_IO.Put_LINE ("INVALID BINDINGS FOR DO");
raise Syntax_Error;
end if;
Ptr1 := Get_Cdr(Ptr1); -- <clause>
if not Is_Cons(Ptr1) then
-- (do ( (i 10) (j 20)))
-- (do ( (i 10) (j 20)) . #f)
Ada.Text_IO.Put_LINE ("NO CLAUSE FOR DO");
raise Syntax_Error;
end if;
Ptr2 := Get_Car(Ptr1); -- <test> in clause;
if not Is_Cons(Ptr2) then
-- (do ( (i 10) (j 20)) #f)
Ada.Text_IO.Put_Line ("INVALID CLAUSE TEST FOR DO");
raise Syntax_Error;
end if;
if Get_Last_Cdr(Ptr2) /= Nil_Pointer then
-- (do ( (i 10) (j 20)) (#f . 10))
-- (do ( (i 10) (j 20)) (#f 20 . 10))
Ada.Text_IO.Put_LINE ("FUCKING CDR IN CLAUSE FOR DO");
raise Syntax_Error;
end if;
if Get_Last_Cdr(Ptr1) /= Nil_Pointer then
-- (do ( (i 10) (j 20 10)) (#f 20) . 10)
Ada.Text_IO.Put_LINE ("FUCKING CDR IN BODY FOR DO");
raise Syntax_Error;
end if;
end Check_Do_Syntax;
procedure Evaluate_Do_Syntax is
pragma Inline (Evaluate_Do_Syntax);
Synlist: Object_Pointer;
Bindings: aliased Object_Pointer;
Envir: aliased Object_Pointer;
begin begin
-- (do <bindings> <clause> <body>) -- (do <bindings> <clause> <body>)
-- <bindings> should be of the form: ((<variable 1> <init 1> <step 1>) ...) -- <bindings> should be of the form: ((<variable 1> <init 1> <step 1>) ...)
@ -402,94 +489,28 @@ procedure Evaluate is
if (Interp.State and Force_Syntax_Check) /= 0 or else if (Interp.State and Force_Syntax_Check) /= 0 or else
(Synlist.Flags and Syntax_Checked) = 0 then (Synlist.Flags and Syntax_Checked) = 0 then
Check_Do_Syntax;
Ptr1 := Operand; -- <bindings> list
if not Is_Cons(Ptr1) then
-- (do)
-- (do . 10)
Ada.Text_IO.Put_LINE ("NO BIDNIGNS FOR DO");
raise Syntax_Error;
end if;
Ptr2 := Get_Car(Ptr1); -- <bindings>
while Is_Cons(Ptr2) loop
Ptr3 := Get_Car(Ptr2); -- <binding>
if not Is_Cons(Ptr3) then
-- (do (i) (#f))
Ada.Text_IO.Put_Line ("INVALID BINDING FOR DO");
raise Syntax_Error;
end if;
if not Is_Symbol(Get_Car(Ptr3)) then -- <variable>
-- (do ((10 10)) (#f))
Ada.Text_IO.Put_Line ("INVALID BINDING VARIABLE FOR DO");
raise Syntax_Error;
end if;
Ptr3 := Get_Cdr(Ptr3); -- <init> cons
if not Is_Cons(Ptr3) then
-- (do ((i . 10)) (#f))
Ada.Text_IO.Put_Line ("NO INIT IN DO BINDING");
raise Syntax_Error;
end if;
-- Get_Car(Ptr3); -- <init>
Ptr3 := Get_Cdr(Ptr3); -- <step> cons
if Is_Cons(Ptr3) then
-- Get_Car(Ptr3); -- <step>
if Get_Cdr(Ptr3) /= Nil_Pointer then
-- (do ((i 0 10 20)) ... )
Ada.Text_IO.PUT_Line ("TOO MANY STEP EXPRESSIONS IN DO BINDING");
raise Syntax_Error;
end if;
elsif Ptr3 /= Nil_Pointer then
-- (do ((i 0 . 10)) ... )
Ada.Text_IO.Put_Line ("FUCKING CDR in DO BIDNING");
raise Syntax_Error;
end if;
Ptr2 := Get_Cdr(Ptr2);
end loop;
if Ptr2 /= Nil_Pointer then
-- (do 10 . 10)
-- (do 10 (#f))
-- (do ((i 10) (j 20) . 10) (#f))
Ada.Text_IO.Put_LINE ("INVALID BINDINGS FOR DO");
raise Syntax_Error;
end if;
Ptr1 := Get_Cdr(Ptr1); -- <clause>
if not Is_Cons(Ptr1) then
-- (do ( (i 10) (j 20)))
-- (do ( (i 10) (j 20)) . #f)
Ada.Text_IO.Put_LINE ("NO CLAUSE FOR DO");
raise Syntax_Error;
end if;
Ptr2 := Get_Car(Ptr1); -- <test> in clause;
if not Is_Cons(Ptr2) then
-- (do ( (i 10) (j 20)) #f)
Ada.Text_IO.Put_Line ("INVALID CLAUSE TEST FOR DO");
raise Syntax_Error;
end if;
if Get_Last_Cdr(Ptr2) /= Nil_Pointer then
-- (do ( (i 10) (j 20)) (#f . 10))
-- (do ( (i 10) (j 20)) (#f 20 . 10))
Ada.Text_IO.Put_LINE ("FUCKING CDR IN CLAUSE FOR DO");
raise Syntax_Error;
end if;
if Get_Last_Cdr(Ptr1) /= Nil_Pointer then
-- (do ( (i 10) (j 20 10)) (#f 20) . 10)
Ada.Text_IO.Put_LINE ("FUCKING CDR IN BODY FOR DO");
raise Syntax_Error;
end if;
Synlist.Flags := Synlist.Flags or Syntax_Checked; Synlist.Flags := Synlist.Flags or Syntax_Checked;
end if; end if;
Ada.Text_IO.Put_LINE ("UNIMPLEMENTED"); Reload_Frame (Interp, Opcode_Do_Test, Operand);
raise Evaluation_Error; Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment
Bindings := Get_Car(Operand); -- <binding> list
if Is_Cons(Bindings) then -- <binding> list
-- <binding> list is not nil.
Push_Top (Interp, Envir'Unchecked_Access);
Push_Top (Interp, Bindings'Unchecked_Access);
Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
Push_Frame (Interp, Opcode_Do_Binding, Bindings); -- first <binding>
Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Bindings))), Envir); -- first <init>
Pop_Tops (Interp, 2);
--else
-- -- <binding> list is nil/empty.
-- -- (do () (#f ... ) ...)
-- Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Car(Get_Cdr(Operand)))); -- <test>
end if;
end Evaluate_Do_Syntax; end Evaluate_Do_Syntax;
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------

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

@ -162,6 +162,86 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
procedure Do_Do_Binding is
pragma Inline (Do_Do_Binding);
X: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
X := Get_Frame_Operand(Interp.StacK);
Set_Parent_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack));
X := Get_Cdr(X);
if Is_Cons(X) then
declare
Envir: aliased Object_Pointer;
begin
pragma Assert (Get_Frame_Opcode(Get_Frame_Parent(Interp.Stack)) = Opcode_Do_Test);
Push_top (Interp, Envir'Unchecked_Access);
Envir := Get_Frame_Environment(Get_Frame_Parent(Get_Frame_Parent(Interp.Stack)));
Reload_Frame (Interp, Opcode_Do_Binding, X);
Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))), Envir); -- <init>
Pop_Tops (Interp, 1);
end;
else
Pop_Frame (Interp);
end if;
Pop_Tops (Interp, 1);
end Do_Do_Binding;
procedure Do_Do_Test is
pragma Inline (Do_Do_Test);
X: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack);
Reload_Frame (Interp, Opcode_Do_Break, X);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Car(Get_Cdr(X)))); -- <test>
Pop_Tops (Interp, 1);
end Do_Do_Test;
procedure Do_Do_Break is
X: aliased Object_Pointer;
begin
X := Get_Frame_Operand(Interp.Stack);
if Is_True_Class(Get_Frame_Result(Interp.Stack)) then
-- <test> is true
X := Get_Cdr(Get_Car(Get_Cdr(X)));
if X = Nil_Pointer then
-- no expression after <test>
-- (do ((x 1)) (#t))
Pop_Frame (Interp);
else
Reload_Frame (Interp, Opcode_Grouped_Call, X);
end if;
else
-- <test> is false
Push_Top (Interp, X'Unchecked_Access);
Reload_Frame (Interp, Opcode_Do_Step, X);
X := Get_Cdr(Get_Cdr(X));
if X /= Nil_Pointer then
Push_Frame (Interp, Opcode_Grouped_Call, X);
end if;
Pop_Tops (Interp, 1);
end if;
end Do_Do_Break;
procedure Do_Do_Step is
begin
-- arrange to evaluate <step> and update binding <variable>.
print (interp, Get_Car(Get_Frame_Operand(Interp.Stack)));
Pop_Frame (Interp);
end Do_Do_Step;
procedure Do_Do_Update is
begin
Pop_Frame (Interp);
null;
end Do_Do_Update;
-- ----------------------------------------------------------------
procedure Do_If_Finish is procedure Do_If_Finish is
pragma Inline (Do_If_Finish); pragma Inline (Do_If_Finish);
X: Object_Pointer; X: Object_Pointer;
@ -980,6 +1060,21 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
when Opcode_Define_Finish => when Opcode_Define_Finish =>
Do_Define_Finish; Do_Define_Finish;
when Opcode_Do_Binding =>
Do_Do_Binding;
when Opcode_Do_Break =>
Do_Do_Break;
when Opcode_Do_Step =>
Do_Do_Step;
when Opcode_Do_Test =>
Do_Do_Test;
when Opcode_Do_Update =>
Do_Do_Update;
when Opcode_Grouped_Call => when Opcode_Grouped_Call =>
Do_Grouped_Call; Do_Grouped_Call;

5
lib/h2-scheme.adb
View File

@ -152,6 +152,11 @@ package body H2.Scheme is
Opcode_Case_Finish, Opcode_Case_Finish,
Opcode_Cond_Finish, Opcode_Cond_Finish,
Opcode_Define_Finish, Opcode_Define_Finish,
Opcode_Do_Binding,
Opcode_Do_Break,
Opcode_Do_Step,
Opcode_Do_Test,
Opcode_Do_Update,
Opcode_Grouped_Call, -- (begin ...), closure apply, let body Opcode_Grouped_Call, -- (begin ...), closure apply, let body
Opcode_If_Finish, Opcode_If_Finish,
Opcode_Let_Binding, Opcode_Let_Binding,

1
lib/h2-scheme.ads
View File

@ -164,6 +164,7 @@ package H2.Scheme is
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#); Syntax_Checked: constant Object_Flags := Object_Flags'(2#0010#);
Argument_Checked: constant Object_Flags := Object_Flags'(2#0100#);
type Syntax_Code is ( type Syntax_Code is (
And_Syntax, And_Syntax,