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

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

@ -355,54 +355,11 @@ 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 begin
-- (do <bindings> <clause> <body>)
-- <bindings> should be of the form: ((<variable 1> <init 1> <step 1>) ...)
-- <clause> should be of the form: (<test> <expression> ...)
-- <body> is zero or more expressions.
--
-- * evaluate <init>.
-- * bind <variable> with the result.
-- * evaluate <test>
-- * if the result is false, evaluate <body>. evaluate <step>.
-- store it into <variable> and go back to evaluate <test>
-- * if the result is true, evaluate <expression> and exit.
--
-- (let ((x '(1 3 5 7 9)))
-- (do ((x x (cdr x))
-- (sum 0 (+ sum (car x)))) ; <bindings> x and sum
-- ((null? x) sum) ; <clause>. if <test> is true, exit do with sum.
-- )
-- )
--
-- (do (
-- (i 0 (+ i 1)) ; i = 0, for each iteration, +1
-- (j 0 (+ j 2)) ; j = 0, for each iteration, +2
-- )
--
-- ((= i 5) i) ; exit returning i if i becomes 5
--
-- (display (* i j)) ; evaluate these until it exits
-- (newline)
-- )
--
-- Infinite loop samples:
-- (do () (#f) (display i))
-- (do ((i 0)) (#f) (display i))
-- (do ((i 0)) (#f) (display i))
Synlist := Operand;
Operand := Get_Cdr(Operand); -- Skip "do"
if (Interp.State and Force_Syntax_Check) /= 0 or else
(Synlist.Flags and Syntax_Checked) = 0 then
Ptr1 := Operand; -- <bindings> list Ptr1 := Operand; -- <bindings> list
if not Is_Cons(Ptr1) then if not Is_Cons(Ptr1) then
-- (do) -- (do)
@ -484,12 +441,76 @@ procedure Evaluate is
Ada.Text_IO.Put_LINE ("FUCKING CDR IN BODY FOR DO"); Ada.Text_IO.Put_LINE ("FUCKING CDR IN BODY FOR DO");
raise Syntax_Error; raise Syntax_Error;
end if; 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
-- (do <bindings> <clause> <body>)
-- <bindings> should be of the form: ((<variable 1> <init 1> <step 1>) ...)
-- <clause> should be of the form: (<test> <expression> ...)
-- <body> is zero or more expressions.
--
-- * evaluate <init>.
-- * bind <variable> with the result.
-- * evaluate <test>
-- * if the result is false, evaluate <body>. evaluate <step>.
-- store it into <variable> and go back to evaluate <test>
-- * if the result is true, evaluate <expression> and exit.
--
-- (let ((x '(1 3 5 7 9)))
-- (do ((x x (cdr x))
-- (sum 0 (+ sum (car x)))) ; <bindings> x and sum
-- ((null? x) sum) ; <clause>. if <test> is true, exit do with sum.
-- )
-- )
--
-- (do (
-- (i 0 (+ i 1)) ; i = 0, for each iteration, +1
-- (j 0 (+ j 2)) ; j = 0, for each iteration, +2
-- )
--
-- ((= i 5) i) ; exit returning i if i becomes 5
--
-- (display (* i j)) ; evaluate these until it exits
-- (newline)
-- )
--
-- Infinite loop samples:
-- (do () (#f) (display i))
-- (do ((i 0)) (#f) (display i))
-- (do ((i 0)) (#f) (display i))
Synlist := Operand;
Operand := Get_Cdr(Operand); -- Skip "do"
if (Interp.State and Force_Syntax_Check) /= 0 or else
(Synlist.Flags and Syntax_Checked) = 0 then
Check_Do_Syntax;
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,