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

added quote, simple integer handling

Browse Source
This commit is contained in:
hyung-hwan 2014-01-08 14:59:48 +00:00
parent c7868449f7
commit de2e462814
2 changed files with 236 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

311
lib/h2-scheme.adb
View File

@ -48,11 +48,11 @@ 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 .. 10; subtype Opcode_Type is Object_Integer range 0 .. 11;
Opcode_Exit: constant Opcode_Type := Opcode_Type'(0); Opcode_Exit: constant Opcode_Type := Opcode_Type'(0);
Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(1); Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(2); -- (begin ...) and closure apply Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2);
Opcode_Evaluate_Syntax: constant Opcode_Type := Opcode_Type'(3); Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply
Opcode_Evaluate_Procedure: constant Opcode_Type := Opcode_Type'(4); Opcode_Evaluate_Procedure: constant Opcode_Type := Opcode_Type'(4);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(5); Opcode_Apply: constant Opcode_Type := Opcode_Type'(5);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(6); Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(6);
@ -60,6 +60,7 @@ package body H2.Scheme is
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(8); Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(9); Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(9);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(10); Opcode_Close_List: constant Opcode_Type := Opcode_Type'(10);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(11);
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- COMMON OBJECTS -- COMMON OBJECTS
@ -73,7 +74,7 @@ package body H2.Scheme is
Frame_Opcode_Index: constant Pointer_Object_Size := 2; Frame_Opcode_Index: constant Pointer_Object_Size := 2;
Frame_Operand_Index: constant Pointer_Object_Size := 3; Frame_Operand_Index: constant Pointer_Object_Size := 3;
Frame_Environment_Index: constant Pointer_Object_Size := 4; Frame_Environment_Index: constant Pointer_Object_Size := 4;
Frame_Return_Index: constant Pointer_Object_Size := 5; Frame_Result_Index: constant Pointer_Object_Size := 5;
Mark_Object_Size: constant Pointer_Object_Size := 1; Mark_Object_Size: constant Pointer_Object_Size := 1;
Mark_Context_Index: constant Pointer_Object_Size := 1; Mark_Context_Index: constant Pointer_Object_Size := 1;
@ -367,6 +368,32 @@ package body H2.Scheme is
end if; end if;
end Print_Object_Pointer; end Print_Object_Pointer;
function String_To_Integer_Pointer (Source: in Object_String) return Object_Pointer is
V: Object_Integer := 0;
Negative: Standard.Boolean := False;
First: Standard.Natural;
begin
-- TODO: BIGNUM, RANGE CHECK, ETC
pragma Assert (Source'Length > 0);
First := Source'First;
if Source(First) = '-' then
First := First + 1;
Negative := Standard.True;
elsif Source(First) = '+' then
First := First + 1;
end if;
for I in First .. Source'Last loop
V := V * 10 + Object_Character'Pos(Source(I)) - Object_Character'Pos('0');
end loop;
if Negative then
V := -V;
end if;
return Integer_To_Pointer(V);
end String_To_Integer_Pointer;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- MEMORY MANAGEMENT -- MEMORY MANAGEMENT
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@ -1180,39 +1207,39 @@ Put_String (To_Thin_String_Pointer (Result));
Source.Tag = Frame_Object; Source.Tag = Frame_Object;
end Is_Frame; end Is_Frame;
function Get_Frame_Return (Frame: in Object_Pointer) return Object_Pointer is function Get_Frame_Result (Frame: in Object_Pointer) return Object_Pointer is
pragma Inline (Get_Frame_Return); pragma Inline (Get_Frame_Result);
pragma Assert (Is_Frame(Frame)); pragma Assert (Is_Frame(Frame));
begin begin
return Frame.Pointer_Slot(Frame_Return_Index); return Frame.Pointer_Slot(Frame_Result_Index);
end Get_Frame_Return; end Get_Frame_Result;
--procedure Set_Frame_Return (Frame: in out Object_Pointer; --procedure Set_Frame_Result (Frame: in out Object_Pointer;
-- Value: in Object_Pointer) is -- Value: in Object_Pointer) is
-- pragma Inline (Set_Frame_Return); -- pragma Inline (Set_Frame_Result);
-- pragma Assert (Is_Frame(Frame)); -- pragma Assert (Is_Frame(Frame));
--begin --begin
-- Frame.Pointer_Slot(Frame_Return_Index) := Value; -- Frame.Pointer_Slot(Frame_Result_Index) := Value;
--end Set_Frame_Return; --end Set_Frame_Result;
procedure Chain_Frame_Return (Interp: in out Interpreter_Record; procedure Chain_Frame_Result (Interp: in out Interpreter_Record;
Frame: in out Object_Pointer; Frame: in out Object_Pointer;
Value: in Object_Pointer) is Value: in Object_Pointer) is
pragma Inline (Chain_Frame_Return); pragma Inline (Chain_Frame_Result);
pragma Assert (Is_Frame(Frame)); pragma Assert (Is_Frame(Frame));
Ret_Head: Object_Pointer renames Frame.Pointer_Slot(Frame_Return_Index); Ret_Head: Object_Pointer renames Frame.Pointer_Slot(Frame_Result_Index);
begin begin
-- TODO: make it GC-aware -- TODO: make it GC-aware
-- Add a new cons cell to the front -- Add a new cons cell to the front
Ret_Head := Make_Cons (Interp.Self, Value, Ret_Head); Ret_Head := Make_Cons (Interp.Self, Value, Ret_Head);
end Chain_Frame_Return; end Chain_Frame_Result;
procedure Clear_Frame_Return (Frame: in out Object_Pointer) is procedure Clear_Frame_Result (Frame: in out Object_Pointer) is
begin begin
Frame.Pointer_Slot(Frame_Return_Index) := Nil_Pointer; Frame.Pointer_Slot(Frame_Result_Index) := Nil_Pointer;
end Clear_Frame_Return; end Clear_Frame_Result;
function Get_Frame_Environment (Frame: in Object_Pointer) return Object_Pointer is function Get_Frame_Environment (Frame: in Object_Pointer) return Object_Pointer is
pragma Inline (Get_Frame_Environment); pragma Inline (Get_Frame_Environment);
@ -1989,6 +2016,20 @@ end Make_Test_Object;
LC: IO_Character_Record renames Interp.Input.Iochar; LC: IO_Character_Record renames Interp.Input.Iochar;
procedure Evaluate_Result is
pragma Inline (Evaluate_Result);
begin
-- The result from the previous frame is stored in the current frame.
-- This procedure takes the result and switch it to an operand and clears it.
-- It is used to evaluate the result of Read_Object in principle.
-- It takes only the head(car) element of the result chain.
-- Calling this function to evaluate the result of any arbitrary frame
-- other than 'Read_Object' is not recommended.
Set_Frame_Operand (Interp.Stack, Get_Car(Get_Frame_Result(Interp.Stack)));
Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object);
end Evaluate_Result;
procedure Evaluate_Group is procedure Evaluate_Group is
pragma Inline (Evaluate_Group); pragma Inline (Evaluate_Group);
@ -2021,20 +2062,20 @@ end Make_Test_Object;
end if; end if;
-- Clear the return value from the previous expression. -- Clear the return value from the previous expression.
Clear_Frame_Return (Interp.Stack); Clear_Frame_Result (Interp.Stack);
-- Arrange to evaluate the current expression -- Arrange to evaluate the current expression
Push_Frame (Interp, Opcode_Evaluate_Object, Car); Push_Frame (Interp, Opcode_Evaluate_Object, Car);
when Mark_Object => when Mark_Object =>
Operand := Get_Frame_Return (Interp.Stack); Operand := Get_Frame_Result (Interp.Stack);
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
-- There must be only 1 return value chained in the Group frame. -- There must be only 1 return value chained in the Group frame.
pragma Assert (Get_Cdr(Operand) = Nil_Pointer); pragma Assert (Get_Cdr(Operand) = Nil_Pointer);
-- Transfer the only return value to the upper chain -- Transfer the only return value to the upper chain
Chain_Frame_Return (Interp, Interp.Stack, Get_Car(Operand)); Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand));
when others => when others =>
raise Internal_Error; raise Internal_Error;
@ -2104,9 +2145,24 @@ end Make_Test_Object;
goto Start_Over; -- for optimization only. not really needed. goto Start_Over; -- for optimization only. not really needed.
end if; end if;
end if; end if;
when Define_Syntax => when Define_Syntax =>
Text_IO.Put_Line ("define syntax"); -- (define x 10)
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- Switch to syntax evaluation -- (define (add x y) (+ x y)) -> (define add (lambda (x y) (+ x y)))
Operand := Cdr; -- Skip "define"
if not Is_Cons(Operand) then
-- e.g) (define)
-- (define . 10)
Text_IO.Put_LINE ("FUCKNING CDR FOR DEFINE");
raise Syntax_Error;
elsif Get_Cdr(Operand) /= Nil_Pointer then
-- TODO: IMPLEMENT OTHER CHECK
end if;
--Pop_Frame (Interp); -- Done
--Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand));
-- TODO: IMPLEMENT DEFINE.
when Lambda_Syntax => when Lambda_Syntax =>
-- (lambda (x y) (+ x y)); -- (lambda (x y) (+ x y));
@ -2136,10 +2192,24 @@ end Make_Test_Object;
begin begin
Closure := Make_Closure (Interp.Self, Operand, Interp.Environment); Closure := Make_Closure (Interp.Self, Operand, Interp.Environment);
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
Chain_Frame_Return (Interp, Interp.Stack, Closure); Chain_Frame_Result (Interp, Interp.Stack, Closure);
end; end;
end if; end if;
when Quote_Syntax =>
Operand := Cdr; -- Skip "quote"
if not Is_Cons(Operand) then
-- e.g) (quote)
-- (quote . 10)
Text_IO.Put_LINE ("FUCKNING CDR FOR QUOTE");
raise Syntax_Error;
elsif Get_Cdr(Operand) /= Nil_Pointer then
Text_IO.Put_LINE ("WRONG NUMBER OF ARGUMENTS FOR QUOTE");
raise Syntax_Error;
end if;
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand));
when others => when others =>
Text_IO.Put_Line ("Unknown syntax"); Text_IO.Put_Line ("Unknown syntax");
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- Switch to syntax evaluation Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- Switch to syntax evaluation
@ -2153,15 +2223,15 @@ end Make_Test_Object;
-- frame without pushing another frame dedicated for it. -- frame without pushing another frame dedicated for it.
-- TODO: some normal pointers may point to a literal object. e.g.) bignum -- TODO: some normal pointers may point to a literal object. e.g.) bignum
Chain_Frame_Return (Interp, Interp.Stack, Car); Chain_Frame_Result (Interp, Interp.Stack, Car);
if Is_Cons(Cdr) then if Is_Cons(Cdr) then
Operand := Cdr; Operand := Cdr;
Car := Get_Car(Operand); Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand); Cdr := Get_Cdr(Operand);
else else
-- last cons -- last cons
Operand := Reverse_Cons(Get_Frame_Return(Interp.Stack)); Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack));
Clear_Frame_Return (Interp.Stack); Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply); Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand); Set_Frame_Operand (Interp.Stack, Operand);
return; return;
@ -2198,8 +2268,8 @@ end Make_Test_Object;
-- Get the evaluation result stored in the current stack frame by -- Get the evaluation result stored in the current stack frame by
-- various sub-Opcode_Evaluate_Object frames. the return value -- various sub-Opcode_Evaluate_Object frames. the return value
-- chain must be reversed Chain_Frame_Return reverse-chains values. -- chain must be reversed Chain_Frame_Result reverse-chains values.
Operand := Reverse_Cons(Get_Frame_Return(Interp.Stack)); Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack));
-- Refresh the current stack frame to Opcode_Apply. -- Refresh the current stack frame to Opcode_Apply.
-- This should be faster than Popping the current frame and pushing -- This should be faster than Popping the current frame and pushing
@ -2207,7 +2277,7 @@ end Make_Test_Object;
-- Envir := Get_Frame_Environment(Interp.Stack); -- Envir := Get_Frame_Environment(Interp.Stack);
-- Pop_Frame (Interp); -- done -- Pop_Frame (Interp); -- done
-- Push_Frame (Interp, Opcode_Apply, Operand, Envir); -- Push_Frame (Interp, Opcode_Apply, Operand, Envir);
Clear_Frame_Return (Interp.Stack); Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply); Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand); Set_Frame_Operand (Interp.Stack, Operand);
@ -2221,25 +2291,9 @@ end Make_Test_Object;
Pop_Frame (Interp); -- done Pop_Frame (Interp); -- done
Text_IO.Put ("Return => "); Text_IO.Put ("Return => ");
Print (Interp, Operand); Print (Interp, Operand);
Chain_Frame_Return (Interp, Interp.Stack, Operand); Chain_Frame_Result (Interp, Interp.Stack, Operand);
end Evaluate_Object; end Evaluate_Object;
procedure Evaluate_Syntax is
pragma Inline (Evaluate_Syntax);
Scode: Syntax_Code;
begin
Scode := Get_Car(Get_Frame_Operand(Interp.Stack)).Scode;
case Scode is
when Begin_Syntax =>
-- not used. Evaluate_Group is used instead.
null;
when Define_Syntax =>
Text_IO.Put_Line ("define syntax");
when others =>
Text_IO.Put_Line ("Unknown syntax");
end case;
end Evaluate_Syntax;
procedure Evaluate_Procedure is procedure Evaluate_Procedure is
pragma Inline (Evaluate_Procedure); pragma Inline (Evaluate_Procedure);
begin begin
@ -2256,13 +2310,13 @@ Print (Interp, Operand);
procedure Apply_Car_Procedure is procedure Apply_Car_Procedure is
begin begin
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Return (Interp, Interp.Stack, Get_Car(Args)); Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Args));
end Apply_Car_Procedure; end Apply_Car_Procedure;
procedure Apply_Cdr_Procedure is procedure Apply_Cdr_Procedure is
begin begin
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Return (Interp, Interp.Stack, Get_Cdr(Args)); Chain_Frame_Result (Interp, Interp.Stack, Get_Cdr(Args));
end Apply_Cdr_Procedure; end Apply_Cdr_Procedure;
procedure Apply_Add_Procedure is procedure Apply_Add_Procedure is
@ -2283,7 +2337,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Return (Interp, Interp.Stack, Integer_To_Pointer(Num)); Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Add_Procedure; end Apply_Add_Procedure;
procedure Apply_Subtract_Procedure is procedure Apply_Subtract_Procedure is
@ -2311,7 +2365,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
end if; end if;
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Return (Interp, Interp.Stack, Integer_To_Pointer(Num)); Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Subtract_Procedure; end Apply_Subtract_Procedure;
procedure Apply_Closure is procedure Apply_Closure is
@ -2370,7 +2424,7 @@ Print (Interp, Arg);
-- TODO: is it correct to keep the environement in the frame? -- TODO: is it correct to keep the environement in the frame?
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Operand (Interp.Stack, Fbody); Set_Frame_Operand (Interp.Stack, Fbody);
Clear_Frame_Return (Interp.Stack); Clear_Frame_Result (Interp.Stack);
end Apply_Closure; end Apply_Closure;
begin begin
@ -2494,6 +2548,7 @@ Print (Interp, Operand);
end Skip_Spaces_And_Comments; end Skip_Spaces_And_Comments;
procedure Fetch_Token is procedure Fetch_Token is
Tmp: Object_String(1..10); -- large enough???
begin begin
if not Interp.LC_Unfetched then if not Interp.LC_Unfetched then
Fetch_Character; Fetch_Character;
@ -2554,6 +2609,56 @@ Print (Interp, Operand);
Fetch_Character; Fetch_Character;
-- TODO: t, false, etc -- TODO: t, false, etc
when '0' .. '9' =>
-- TODO; negative number, floating-point number, bignum, hexdecimal, etc
Token.Set (Interp, Integer_Token, "");
loop
Token.Append_Character (Interp, LC.Value);
Fetch_Character;
if LC.Kind /= Normal_Character or else
not (LC.Value in '0' .. '9') then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
exit;
end if;
end loop;
when '-' | '+' =>
Tmp(1) := LC.Value;
Fetch_Character;
if LC.Kind = Normal_Character and then
LC.Value in '0' .. '9' then
Token.Set (Interp, Integer_Token, Tmp(1..1));
loop
Token.Append_Character (Interp, LC.Value);
Fetch_Character;
if LC.Kind /= Normal_Character or else
not (LC.Value in '0' .. '9') then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
exit;
end if;
end loop;
else
Token.Set (Interp, Identifier_Token, Tmp(1..1));
loop
-- TODO: more characters
if LC.Kind /= Normal_Character or else
LC.Value = '(' or else LC.Value = ')' or else
LC.Value = ''' or else LC.Value = '"' or else
LC.Value = '#' or else LC.Value = ';' or else
Is_White_Space(LC.Value) then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
exit;
end if;
Token.Append_Character (Interp, LC.Value);
Fetch_Character;
end loop;
end if;
when others => when others =>
Token.Set (Interp, Identifier_Token, ""); Token.Set (Interp, Identifier_Token, "");
loop loop
@ -2561,7 +2666,8 @@ Print (Interp, Operand);
Fetch_Character; Fetch_Character;
--exit when not Is_Ident_Char(C.Value); --exit when not Is_Ident_Char(C.Value);
-- TODO: more characters -- TODO: more characters
if LC.Value = '(' or else LC.Value = ')' or else if LC.Kind /= Normal_Character or else
LC.Value = '(' or else LC.Value = ')' or else
LC.Value = ''' or else LC.Value = '"' or else LC.Value = ''' or else LC.Value = '"' or else
LC.Value = '#' or else LC.Value = ';' or else LC.Value = '#' or else LC.Value = ';' or else
Is_White_Space(LC.Value) then Is_White_Space(LC.Value) then
@ -2576,6 +2682,7 @@ Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>> Token: " & Interp.Token.Value.Ptr(1..
end Fetch_Token; end Fetch_Token;
procedure Read_List is procedure Read_List is
pragma Inline (Read_List);
V: Object_Pointer; V: Object_Pointer;
begin begin
-- This procedure reads each token in a list. -- This procedure reads each token in a list.
@ -2594,15 +2701,15 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
Push_Frame (Interp, Opcode_Read_List, Nil_Pointer); Push_Frame (Interp, Opcode_Read_List, Nil_Pointer);
when Right_Parenthesis_Token => when Right_Parenthesis_Token =>
V := Get_Frame_Return(Interp.Stack); V := Get_Frame_Result(Interp.Stack);
if V /= Nil_Pointer then if V /= Nil_Pointer then
V := Reverse_Cons(V); -- TODO: GC V := Reverse_Cons(V); -- TODO: GC
end if; end if;
Pop_Frame (Interp); Pop_Frame (Interp);
Chain_Frame_Return (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when Period_Token => when Period_Token =>
V := Get_Frame_Return(Interp.Stack); V := Get_Frame_Result(Interp.Stack);
if V = Nil_Pointer then if V = Nil_Pointer then
-- . immediately after ( -- . immediately after (
raise Syntax_Error; raise Syntax_Error;
@ -2610,15 +2717,24 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_Cdr); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_Cdr);
end if; end if;
when Single_Quote_Token =>
Push_Frame (Interp, Opcode_Close_Quote, Nil_Pointer);
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
when Integer_Token =>
-- TODO: bignum
V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Result (Interp, Interp.Stack, V);
when String_Token => when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware -- TODO: make V gc-aware
Chain_Frame_Return (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token => when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware -- TODO: make V gc-aware
Chain_Frame_Return (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when others => when others =>
-- TODO: set various error info -- TODO: set various error info
@ -2627,13 +2743,14 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
end Read_List; end Read_List;
procedure Read_List_Cdr is procedure Read_List_Cdr is
pragma Inline (Read_List_Cdr);
V: Object_Pointer; V: Object_Pointer;
begin begin
-- This procedure reads the first token after a period has been read. -- This procedure reads the first token after a period has been read.
-- It transfers the control over to Read_List_End once it has read -- It transfers the control over to Read_List_End once it has read
-- and processed the token. It chains the value made of the token -- and processed the token. It chains the value made of the token
-- to the front of the frame's return value list expecting Read_List_End -- to the front of the frame's return value list expecting Read_List_End
-- to handle the first item specially. -- to handle the head item specially.
Fetch_Token; Fetch_Token;
case Interp.Token.Kind is case Interp.Token.Kind is
@ -2645,17 +2762,29 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Push_Frame (Interp, Opcode_Read_List, Nil_Pointer); Push_Frame (Interp, Opcode_Read_List, Nil_Pointer);
when Single_Quote_Token =>
Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Push_Frame (Interp, Opcode_Close_Quote, Nil_Pointer);
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
when Integer_Token =>
-- TODO: bignum
V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, V);
when String_Token => when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware -- TODO: make V gc-aware
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Return (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token => when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware -- TODO: make V gc-aware
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Return (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when others => when others =>
-- TODO: set various error info -- TODO: set various error info
@ -2665,6 +2794,7 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
end Read_List_Cdr; end Read_List_Cdr;
procedure Read_List_End is procedure Read_List_End is
pragma Inline (Read_List_End);
V: Object_Pointer; V: Object_Pointer;
A: Object_Pointer; A: Object_Pointer;
begin begin
@ -2672,28 +2802,40 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
case Interp.Token.Kind is case Interp.Token.Kind is
when Right_Parenthesis_Token => when Right_Parenthesis_Token =>
V := Get_Frame_Return(Interp.Stack); V := Get_Frame_Result(Interp.Stack);
pragma Assert (V /= Nil_Pointer); pragma Assert (V /= Nil_Pointer);
-- The first item in the chain is actually Cdr of the last cell. -- The first item in the chain is actually Cdr of the last cell.
V := Reverse_Cons(Get_Cdr(V), Get_Car(V)); -- TODO: GC V := Reverse_Cons(Get_Cdr(V), Get_Car(V)); -- TODO: GC
Pop_Frame (Interp); Pop_Frame (Interp);
Chain_Frame_Return (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when others => when others =>
raise Syntax_Error; raise Syntax_Error;
end case; end case;
end Read_List_End; end Read_List_End;
procedure Close_List is procedure Close_List is
pragma Inline (Close_List);
V: Object_Pointer; V: Object_Pointer;
begin begin
V := Get_Frame_Return(Interp.Stack); V := Get_Frame_Result(Interp.Stack);
pragma Assert (Get_Cdr(V) = Nil_Pointer); pragma Assert (Get_Cdr(V) = Nil_Pointer);
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Return (Interp, Interp.Stack, Get_Car(V)); Chain_Frame_Result (Interp, Interp.Stack, Get_Car(V));
end Close_List; end Close_List;
procedure Close_Quote is
pragma Inline (Close_Quote);
V: Object_Pointer;
begin
-- TODO: use Interp.Quote_Syntax instead of Make_Symbol("quote")
Chain_Frame_Result (Interp, Interp.Stack, Make_Symbol(Interp.Self, "quote"));
V := Get_Frame_Result(Interp.Stack);
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
end Close_Quote;
procedure Read_Object is procedure Read_Object is
pragma Inline (Read_Object);
V: Object_Pointer; V: Object_Pointer;
begin begin
Fetch_Token; Fetch_Token;
@ -2707,17 +2849,27 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
Set_Frame_Opcode (Interp.Stack, Opcode_Close_List); Set_Frame_Opcode (Interp.Stack, Opcode_Close_List);
Push_Frame (Interp, Opcode_Read_List, Nil_Pointer); Push_Frame (Interp, Opcode_Read_List, Nil_Pointer);
when Single_Quote_Token =>
Set_Frame_Opcode (Interp.Stack, Opcode_Close_Quote);
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
when Integer_Token =>
-- TODO: bignum
V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
when String_Token => when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware -- TODO: make V gc-aware
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Return (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token => when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware -- TODO: make V gc-aware
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Return (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when others => when others =>
-- TODO: set various error info -- TODO: set various error info
@ -2729,7 +2881,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
-- Stack frames looks like this upon initialization -- Stack frames looks like this upon initialization
-- --
-- | Opcode | Operand | Return -- | Opcode | Operand | Result
-- ----------------------------------------------------------------- -- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | Source | Nil -- top | Opcode_Evaluate_Object | Source | Nil
-- bottom | Opcode_Exit | Nil | Nil -- bottom | Opcode_Exit | Nil | Nil
@ -2794,15 +2946,15 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
when Opcode_Exit => when Opcode_Exit =>
exit; exit;
when Opcode_Evaluate_Result =>
Evaluate_Result;
when Opcode_Evaluate_Object => when Opcode_Evaluate_Object =>
Evaluate_Object; Evaluate_Object;
when Opcode_Evaluate_Group => when Opcode_Evaluate_Group =>
Evaluate_Group; Evaluate_Group;
when Opcode_Evaluate_Syntax =>
Evaluate_Syntax;
when Opcode_Evaluate_Procedure => when Opcode_Evaluate_Procedure =>
Evaluate_Procedure; Evaluate_Procedure;
@ -2824,6 +2976,9 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
when Opcode_Close_List => when Opcode_Close_List =>
Close_List; Close_List;
when Opcode_Close_Quote =>
Close_Quote;
end case; end case;
end loop; end loop;
@ -2859,7 +3014,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit); pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);
Result := Get_Frame_Return (Interp.Stack); Result := Get_Frame_Result (Interp.Stack);
-- There must be only 1 value chained to the top-level frame -- There must be only 1 value chained to the top-level frame
-- once evaluation is over. -- once evaluation is over.
pragma Assert (Get_Cdr(Result) = Nil_Pointer); pragma Assert (Get_Cdr(Result) = Nil_Pointer);
@ -2882,8 +3037,8 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
Interp.Stack := Nil_Pointer; Interp.Stack := Nil_Pointer;
Push_Frame (Interp, Opcode_Exit, Nil_Pointer); Push_Frame (Interp, Opcode_Exit, Nil_Pointer);
--Push_Frame (Interp, Opcode_Print, Nil_Pointer); --Push_Frame (Interp, Opcode_Print_Result, Nil_Pointer);
--Push_Frame (Interp, Opcode_Evaluate_Object, Nil_Pointer); Push_Frame (Interp, Opcode_Evaluate_Result, Nil_Pointer);
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer); Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
Execute (Interp); Execute (Interp);
@ -2891,7 +3046,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit); pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);
-- TODO: this result must be kept at some where that GC dowsn't sweep. -- TODO: this result must be kept at some where that GC dowsn't sweep.
Result := Get_Frame_Return (Interp.Stack); Result := Get_Frame_Result (Interp.Stack);
pragma Assert (Get_Cdr(Result) = Nil_Pointer); pragma Assert (Get_Cdr(Result) = Nil_Pointer);
Result := Get_Car(Result); Result := Get_Car(Result);
Pop_Frame (Interp); Pop_Frame (Interp);

3
lib/h2-scheme.ads
View File

@ -445,7 +445,8 @@ private
Right_Parenthesis_Token, Right_Parenthesis_Token,
Period_Token, Period_Token,
Single_Quote_Token, Single_Quote_Token,
String_Token String_Token,
Integer_Token
); );
type Token_Record is record type Token_Record is record