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

started implementing let

Browse Source
This commit is contained in:
hyung-hwan 2014-01-21 14:55:08 +00:00
parent 3ef11302e1
commit 24e62d6f81
4 changed files with 146 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -45,7 +45,6 @@ procedure Evaluate is
Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE"); Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
end Evaluate_Define_Syntax; end Evaluate_Define_Syntax;
procedure Evaluate_If_Syntax is procedure Evaluate_If_Syntax is
@ -110,13 +109,14 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
if not Is_Cons(Operand) then if not Is_Cons(Operand) then
-- e.g) (lambda) -- e.g) (lambda)
-- (lambda . 10) -- (lambda . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN"); Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR LAMBDA");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Car := Get_Car(Operand); -- <formals> Car := Get_Car(Operand); -- <formals>
if Is_Symbol(Car) then if Is_Symbol(Car) then
-- (lambda x ...) -- (lambda x ...)
-- nothing to do.
null; null;
elsif Is_Cons(Car) then elsif Is_Cons(Car) then
declare declare
@ -178,6 +178,86 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end; end;
end Evaluate_Lambda_Syntax; end Evaluate_Lambda_Syntax;
procedure Evaluate_Let_Syntax is
pragma Inline (Evaluate_Let_Syntax);
begin
-- let <bindings> <body>
Operand := Cdr; -- Skip "let".
if not Is_Cons(Operand) then
-- e.g) (let)
-- (let . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR LET");
raise Syntax_Error;
end if;
Car := Get_Car(Operand); -- <bindings>
if not Is_Cons(Car) then
Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET");
raise Syntax_Error;
end if;
Cdr := Get_Cdr(Operand); -- cons cell to <body>
if not Is_Cons(Cdr) then
-- (let ((x 2)) )
-- (let ((x 2)) . 99)
Ada.Text_IO.Put_Line ("INVALID BODY FOR LET");
raise Syntax_Error;
end if;
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Let);
Set_Frame_Operand (Interp.Stack, Operand);
declare
Bindings: aliased Object_Pointer := Car;
Binding_Name: Object_Pointer;
Binding_Value: Object_Pointer;
V: Object_Pointer;
begin
Push_Top (Interp, Bindings'Unchecked_Access);
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
Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET");
raise Syntax_Error;
end if;
Binding_Name := Get_Car(Car);
if not Is_Symbol(Binding_Name) then
Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET");
raise Syntax_Error;
end if;
Binding_Value := Get_Car(Get_Cdr(Car));
Push_Frame (Interp, Opcode_Evaluate_Object, Binding_Value);
-- TODO: check duplicate
--V := Formals;
--loop
-- exit when V = Cdr;
-- if Get_Car(V) = Car then
-- Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET");
-- raise Syntax_Error;
-- end if;
--
-- V := Get_Cdr(V);
-- end loop;
Cdr := Get_Cdr(Cdr);
exit when not Is_Cons(Cdr);
end loop;
Pop_Tops (Interp, 1);
end;
-- if Cdr /= Nil_Pointer and then not Is_Symbol(Cdr) then
-- Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA");
-- raise Syntax_Error;
-- end if;
end Evaluate_Let_Syntax;
procedure Evaluate_Quote_Syntax is procedure Evaluate_Quote_Syntax is
pragma Inline (Evaluate_Quote_Syntax); pragma Inline (Evaluate_Quote_Syntax);
begin begin
@ -302,6 +382,9 @@ begin
when Lambda_Syntax => when Lambda_Syntax =>
Evaluate_Lambda_Syntax; Evaluate_Lambda_Syntax;
when Let_Syntax =>
Evaluate_Let_Syntax;
when Quote_Syntax => when Quote_Syntax =>
Evaluate_Quote_Syntax; Evaluate_Quote_Syntax;

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

@ -135,6 +135,13 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Finish_If; end Finish_If;
procedure Finish_Let is
pragma Inline (Finish_Let);
begin
ada.text_io.put_line ("Finish_Let");
null;
end Finish_Let;
procedure Finish_Set is procedure Finish_Set is
pragma Inline (Finish_Set); pragma Inline (Finish_Set);
X: aliased Object_Pointer; X: aliased Object_Pointer;
@ -288,6 +295,8 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- #t -- #t
-- #f -- #f
-- #\C -- character -- #\C -- character
-- #\xHHHH -- unicode
-- #\xHHHHHHHH -- unicode
-- #( ) -- vector -- #( ) -- vector
-- #[ ] -- list -- #[ ] -- list
-- #{ } -- hash table -- #{ } -- hash table
@ -322,6 +331,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
if Interp.Token.Value.Last > 1 then if Interp.Token.Value.Last > 1 then
-- TODO: case insensitive match. binary search for more diverse words -- TODO: case insensitive match. binary search for more diverse words
-- TODO: #\xHHHH....
if Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Newline then if Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Newline then
Token.Set (Interp, Character_Token, Ch.LF); -- reset the token to LF Token.Set (Interp, Character_Token, Ch.LF); -- reset the token to LF
elsif Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Space then elsif Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Space then
@ -788,6 +798,9 @@ begin
when Opcode_Finish_If => when Opcode_Finish_If =>
Finish_If; Finish_If;
when Opcode_Finish_Let =>
Finish_Let;
when Opcode_Finish_Set => when Opcode_Finish_Set =>
Finish_Set; Finish_Set;

27
lib/h2-scheme.adb
View File

@ -31,12 +31,15 @@ package body H2.Scheme is
Label_Case: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_S, Ch.LC_E); -- "case" Label_Case: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_S, Ch.LC_E); -- "case"
Label_Cond: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_D); -- "cond" Label_Cond: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_D); -- "cond"
Label_Define: constant Object_Character_Array := (Ch.LC_D, Ch.LC_E, Ch.LC_F, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "define" Label_Define: constant Object_Character_Array := (Ch.LC_D, Ch.LC_E, Ch.LC_F, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "define"
Label_Do: constant Object_Character_Array := (Ch.LC_D, Ch.LC_O); -- "do"
Label_If: constant Object_Character_Array := (Ch.LC_I, Ch.LC_F); -- "if" Label_If: constant Object_Character_Array := (Ch.LC_I, Ch.LC_F); -- "if"
Label_Lambda: constant Object_Character_Array := (Ch.LC_L, Ch.LC_A, Ch.LC_M, Ch.LC_B, Ch.LC_D, Ch.LC_A); -- "lambda" Label_Lambda: constant Object_Character_Array := (Ch.LC_L, Ch.LC_A, Ch.LC_M, Ch.LC_B, Ch.LC_D, Ch.LC_A); -- "lambda"
Label_Let: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T); -- "let" Label_Let: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T); -- "let"
Label_Letast: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.Asterisk); -- "let*" Label_Letast: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.Asterisk); -- "let*"
Label_Letrec: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.LC_R, Ch.LC_E, Ch.LC_C); -- "letrec" Label_Letrec: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.LC_R, Ch.LC_E, Ch.LC_C); -- "letrec"
Label_Or: constant Object_Character_Array := (Ch.LC_O, Ch.LC_R); -- "or" Label_Or: constant Object_Character_Array := (Ch.LC_O, Ch.LC_R); -- "or"
Label_Quasiquote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_A, Ch.LC_S, Ch.LC_I,
Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quasiquote"
Label_Quote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quote" Label_Quote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quote"
Label_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!" Label_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!"
@ -80,21 +83,22 @@ 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 .. 13; subtype Opcode_Type is Object_Integer range 0 .. 14;
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);
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply
Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4); Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4);
Opcode_Finish_If: constant Opcode_Type := Opcode_Type'(5); Opcode_Finish_If: constant Opcode_Type := Opcode_Type'(5);
Opcode_Finish_Set: constant Opcode_Type := Opcode_Type'(6); Opcode_Finish_Let: constant Opcode_Type := Opcode_Type'(6);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(7); Opcode_Finish_Set: constant Opcode_Type := Opcode_Type'(7);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(8); Opcode_Apply: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(9); Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(10); Opcode_Read_List: constant Opcode_Type := Opcode_Type'(10);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(11); Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(11);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(12); Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(12);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(13); Opcode_Close_List: constant Opcode_Type := Opcode_Type'(13);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(14);
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- COMMON OBJECTS -- COMMON OBJECTS
@ -739,6 +743,7 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
-- Migrate the symbol table itself -- Migrate the symbol table itself
Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table); Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table);
Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow); Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow);
Interp.Symbol.Quasiquote := Move_One_Object(Interp.Symbol.Quasiquote);
Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote); Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote);
-- Update temporary object pointers that were pointing to the symbol table -- Update temporary object pointers that were pointing to the symbol table
@ -1235,7 +1240,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
pragma Inline (Push_Environment); pragma Inline (Push_Environment);
pragma Assert (Is_Cons(Interp.Environment)); pragma Assert (Is_Cons(Interp.Environment));
begin begin
Interp.Environment := Make_Environment (Interp.Self, Interp.Environment); Interp.Environment := Make_Environment(Interp.Self, Interp.Environment);
end Push_Environment; end Push_Environment;
procedure Pop_Environment (Interp: in out Interpreter_Record) is procedure Pop_Environment (Interp: in out Interpreter_Record) is
@ -1606,6 +1611,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Dummy := Make_Syntax (Interp.Self, Case_Syntax, Label_Case); -- "case" Dummy := Make_Syntax (Interp.Self, Case_Syntax, Label_Case); -- "case"
Dummy := Make_Syntax (Interp.Self, Cond_Syntax, Label_Cond); -- "cond" Dummy := Make_Syntax (Interp.Self, Cond_Syntax, Label_Cond); -- "cond"
Dummy := Make_Syntax (Interp.Self, Define_Syntax, Label_Define); -- "define" Dummy := Make_Syntax (Interp.Self, Define_Syntax, Label_Define); -- "define"
Dummy := Make_Syntax (Interp.Self, Do_Syntax, Label_Do); -- "do"
Dummy := Make_Syntax (Interp.Self, If_Syntax, Label_If); -- "if" Dummy := Make_Syntax (Interp.Self, If_Syntax, Label_If); -- "if"
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"
@ -1613,6 +1619,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Dummy := Make_Syntax (Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrc" 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, 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"
Dummy := Make_Syntax (Interp.Self, Set_Syntax, Label_Set); -- "set!" Dummy := Make_Syntax (Interp.Self, Set_Syntax, Label_Set); -- "set!"
end Make_Syntax_Objects; end Make_Syntax_Objects;

21
lib/h2-scheme.ads
View File

@ -170,14 +170,16 @@ package H2.Scheme is
Case_Syntax: constant Syntax_Code := Syntax_Code'(2); Case_Syntax: constant Syntax_Code := Syntax_Code'(2);
Cond_Syntax: constant Syntax_Code := Syntax_Code'(3); Cond_Syntax: constant Syntax_Code := Syntax_Code'(3);
Define_Syntax: constant Syntax_Code := Syntax_Code'(4); Define_Syntax: constant Syntax_Code := Syntax_Code'(4);
If_Syntax: constant Syntax_Code := Syntax_Code'(5); Do_Syntax: constant Syntax_Code := Syntax_Code'(5);
Lambda_Syntax: constant Syntax_Code := Syntax_Code'(6); If_Syntax: constant Syntax_Code := Syntax_Code'(6);
Let_Syntax: constant Syntax_Code := Syntax_Code'(7); Lambda_Syntax: constant Syntax_Code := Syntax_Code'(7);
Letast_Syntax: constant Syntax_Code := Syntax_Code'(8); Let_Syntax: constant Syntax_Code := Syntax_Code'(8);
Letrec_Syntax: constant Syntax_Code := Syntax_Code'(9); Letast_Syntax: constant Syntax_Code := Syntax_Code'(9);
Or_Syntax: constant Syntax_Code := Syntax_Code'(10); Letrec_Syntax: constant Syntax_Code := Syntax_Code'(10);
Quote_Syntax: constant Syntax_Code := Syntax_Code'(11); Or_Syntax: constant Syntax_Code := Syntax_Code'(11);
Set_Syntax: constant Syntax_Code := Syntax_Code'(12); Quasiquote_Syntax: constant Syntax_Code := Syntax_Code'(12);
Quote_Syntax: constant Syntax_Code := Syntax_Code'(13);
Set_Syntax: constant Syntax_Code := Syntax_Code'(14);
subtype Procedure_Code is Object_Integer; subtype Procedure_Code is Object_Integer;
Add_Procedure: constant Procedure_Code := Procedure_Code'(0); Add_Procedure: constant Procedure_Code := Procedure_Code'(0);
@ -473,8 +475,9 @@ private
end record; end record;
type Common_Symbol_Record is record type Common_Symbol_Record is record
Quote: Object_Pointer := Nil_Pointer;
Arrow: Object_Pointer := Nil_Pointer; Arrow: Object_Pointer := Nil_Pointer;
Quasiquote: Object_Pointer := Nil_Pointer;
Quote: Object_Pointer := Nil_Pointer;
end record; end record;
--type Interpreter_Record is tagged limited record --type Interpreter_Record is tagged limited record