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

implemented if

Browse Source
This commit is contained in:
hyung-hwan 2014-01-20 14:34:55 +00:00
parent 097dcd6a1f
commit af588f1430
7 changed files with 149 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib/ascii.txt
View File

@ -59,7 +59,7 @@ Nine
Colon
Semicolon
Less_Than_Sign
Equals_Sign
Equal_Sign
Greater_Than_Sign
Question
Commercial_At

4
lib/h2-ascii.ads
View File

@ -67,7 +67,7 @@ package H2.Ascii is
Colon : constant := 58; -- :
Semicolon : constant := 59; -- ;
Less_Than_Sign : constant := 60; -- <
Equals_Sign : constant := 61; -- =
Equal_Sign : constant := 61; -- =
Greater_Than_Sign : constant := 62; -- >
Question : constant := 63; -- ?
Commercial_At : constant := 64; -- @
@ -197,7 +197,7 @@ package H2.Ascii is
Colon : constant Character_Type := Character_Type'Val(Pos.Colon);
Semicolon : constant Character_Type := Character_Type'Val(Pos.Semicolon);
Less_Than_Sign : constant Character_Type := Character_Type'Val(Pos.Less_Than_Sign);
Equals_Sign : constant Character_Type := Character_Type'Val(Pos.Equals_Sign);
Equal_Sign : constant Character_Type := Character_Type'Val(Pos.Equal_Sign);
Greater_Than_Sign : constant Character_Type := Character_Type'Val(Pos.Greater_Than_Sign);
Question : constant Character_Type := Character_Type'Val(Pos.Question);
Commercial_At : constant Character_Type := Character_Type'Val(Pos.Commercial_At);

1
lib/h2-scheme-execute-apply.adb
View File

@ -131,6 +131,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
end if;
Num := Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
while Ptr /= Nil_Pointer loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error

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

@ -47,6 +47,57 @@ procedure Evaluate is
end Evaluate_Define_Syntax;
procedure Evaluate_If_Syntax is
pragma Inline (Evaluate_If_Syntax);
begin
-- (if <test> <consequent>)
-- (if <test> <consequent> <alternate>)
-- (if (> 3 2) 'yes)
-- (if (> 3 2) 'yes 'no)
-- (if (> 3 2) (- 3 2) (+ 3 2))
Operand := Cdr; -- Skip "if"
if Not Is_Cons(Operand) then
-- e.g) (if)
-- (if . 10)
Ada.Text_IO.Put_LINE ("NO CONDITIONAL FOR IF");
raise Syntax_Error;
end if;
Car := Get_Car(Operand); -- <test>
Operand := Get_Cdr(Operand); -- cons cell containg <consequent>
if not Is_Cons(Operand) then
Ada.Text_IO.Put_Line ("NO ACTION FOR IF");
raise Syntax_Error;
end if;
Cdr := Get_Cdr(Operand); -- cons cell containing <alternate>
if Cdr = Nil_Pointer then
-- no <alternate>. it's ok
Ada.Text_IO.Put_Line ("NO ALTERNATE");
null;
elsif not Is_Cons(Cdr) then
-- no <alternate> but reduncant cdr.
-- (if (> 3 2) 3 . 99)
Ada.Text_IO.Put_Line ("FUCKING CDR FOR IF");
raise Syntax_Error;
elsif Get_Cdr(Cdr) /= Nil_Pointer then
-- (if (> 3 2) 3 2 . 99)
-- (if (> 3 2) 3 2 99)
Ada.Text_IO.Put_Line ("TOO MANY ARGUMENTS FOR IF");
raise Syntax_Error;
end if;
-- Switch the current frame to execute action after <test> evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If);
Set_Frame_Operand (Interp.Stack, Operand);
-- Arrange to evalaute the conditional
Push_Frame (Interp, Opcode_Evaluate_Object, Car);
end Evaluate_If_Syntax;
procedure Evaluate_Lambda_Syntax is
pragma Inline (Evaluate_Lambda_Syntax);
begin
@ -142,7 +193,6 @@ begin
-- (begin . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
raise Syntax_Error;
--Pop_Frame (Interp); -- Done
else
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
@ -161,6 +211,9 @@ begin
when Define_Syntax =>
Evaluate_Define_Syntax;
when If_Syntax =>
Evaluate_If_Syntax;
when Lambda_Syntax =>
Evaluate_Lambda_Syntax;

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

@ -45,7 +45,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
if Cdr /= Nil_Pointer then
-- The last CDR is not Nil.
Ada.Text_IO.Put_Line ("$$$$..................FUCKING CDR. FOR GROUP....................$$$$");
-- raise Syntax_Error;
raise Syntax_Error;
end if;
-- Change the operand to a mark object so that the call to this
@ -86,8 +86,8 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack);
Y := Get_Car(Get_Frame_Result(Interp.Stack));
X := Get_Frame_Operand(Interp.Stack); -- symbol
Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- value
pragma Assert (Is_Symbol(X));
pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
@ -99,6 +99,41 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
Pop_Tops (Interp, 2);
end Finish_Define_Symbol;
procedure Finish_If is
pragma Inline (Finish_If);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
Z: aliased Object_Pointer;
begin
Ada.Text_IO.PUt_Line ("FINISH IF");
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- cons cell containing <consequent>
Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- result of conditional
pragma Assert (Is_Cons(X));
pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
Pop_Frame (Interp);
if Y = False_Pointer then
-- <test> evaluated to #f.
X := Get_Cdr(X); -- cons cell containing <alternate>
if Is_Cons(X) then
-- evaluate <alternate>
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
else
-- return nil if no <alternate> is specified
Chain_Frame_Result (Interp, Interp.Stack, Nil_Pointer);
end if;
else
-- all values except #f are true values. evaluate <consequent>
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
end if;
Pop_Tops (Interp, 2);
end Finish_If;
procedure Evaluate is separate;
procedure Apply is separate;
@ -449,6 +484,12 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
V := Make_Symbol(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Result (Interp, Interp.Stack, V);
when True_Token =>
Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
when False_Token =>
Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
when others =>
-- TODO: set various error info
raise Syntax_Error;
@ -507,6 +548,14 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, V);
when True_Token =>
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
when False_Token =>
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
when others =>
-- TODO: set various error info
raise Syntax_Error;
@ -558,8 +607,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
begin
--Push_Top (Interp, V'Unchecked_Access);
-- TODO: use Interp.Quote_Syntax instead of Make_Symbol("quote")
Chain_Frame_Result (Interp, Interp.Stack, Make_Symbol(Interp.Self, Label_Quote));
Chain_Frame_Result (Interp, Interp.Stack, Interp.Symbol.Quote);
V := Get_Frame_Result(Interp.Stack);
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
@ -610,6 +658,15 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
when True_Token =>
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
when False_Token =>
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
when others =>
-- TODO: set various error info
raise Syntax_Error;
@ -702,6 +759,9 @@ begin
when Opcode_Finish_Define_Symbol =>
Finish_Define_Symbol;
when Opcode_Finish_If =>
Finish_If;
when Opcode_Apply =>
Apply;

29
lib/h2-scheme.adb
View File

@ -54,6 +54,8 @@ package body H2.Scheme is
Label_Newline: constant Object_Character_Array := (Ch.LC_N, Ch.LC_E, Ch.LC_W, Ch.LC_L, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "newline"
Label_Space: constant Object_Character_Array := (Ch.LC_S, Ch.LC_P, Ch.LC_A, Ch.LC_C, Ch.LC_E); -- "space"
Label_Arrow: constant Object_Character_Array := (Ch.Equal_Sign, Ch.Greater_Than_Sign); -- "=>"
-----------------------------------------------------------------------------
-- EXCEPTIONS
-----------------------------------------------------------------------------
@ -78,19 +80,20 @@ package body H2.Scheme is
subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
subtype Opcode_Type is Object_Integer range 0 .. 11;
subtype Opcode_Type is Object_Integer range 0 .. 12;
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);
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply
Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(5);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(6);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(7);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(9);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(10);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(11);
Opcode_Finish_If: constant Opcode_Type := Opcode_Type'(5);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(6);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(7);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(10);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(11);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(12);
-----------------------------------------------------------------------------
-- COMMON OBJECTS
@ -734,6 +737,8 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
--Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table);
-- Migrate the symbol table itself
Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table);
Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow);
Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote);
-- Update temporary object pointers that were pointing to the symbol table
if Original_Symbol_Table /= null then
@ -1580,7 +1585,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
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, Or_Syntax, Label_Or); -- "or"
Dummy := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote"
Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote"
Dummy := Make_Syntax (Interp.Self, Set_Syntax, Label_Set); -- "set!"
end Make_Syntax_Objects;
@ -1598,6 +1603,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure, Label_Setcdr); -- "set-cdr!"
Dummy := Make_Procedure (Interp.Self, Subtract_Procedure, Label_Minus); -- "-"
end Make_Procedure_Objects;
procedure Make_Common_Symbol_Objects is
begin
Interp.Symbol.Arrow := Make_Symbol (Interp.Self, Label_Arrow);
end Make_Common_Symbol_Objects;
begin
declare
Aliased_Interp: aliased Interpreter_Record;
@ -1636,6 +1646,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Interp.Environment := Interp.Root_Environment;
Make_Syntax_Objects;
Make_Procedure_Objects;
Make_Common_Symbol_Objects;
exception
when others =>

6
lib/h2-scheme.ads
View File

@ -471,6 +471,11 @@ private
Data: Top_Array(1 .. 100) := (others => null);
end record;
type Common_Symbol_Record is record
Quote: Object_Pointer := Nil_Pointer;
Arrow: Object_Pointer := Nil_Pointer;
end record;
--type Interpreter_Record is tagged limited record
type Interpreter_Record is limited record
Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer
@ -488,6 +493,7 @@ private
Stack: aliased Object_Pointer := Nil_Pointer;
Mark: Object_Pointer := Nil_Pointer;
Symbol: Common_Symbol_Record;
Top: Top_Record; -- temporary object pointers
Base_Input: aliased IO_Record;