written more code for reading expressions
This commit is contained in:
parent
78fb4223e9
commit
73c29ce53b
@ -43,13 +43,17 @@ begin
|
|||||||
--S.Set_Input_Stream (SI, String_Stream);
|
--S.Set_Input_Stream (SI, String_Stream);
|
||||||
--S.Set_Output_Stream (SI, Stream); -- specify main output stream.
|
--S.Set_Output_Stream (SI, Stream); -- specify main output stream.
|
||||||
|
|
||||||
S.Read (SI, I);
|
--S.Read (SI, I);
|
||||||
S.Make_Test_Object (SI, I);
|
S.Make_Test_Object (SI, I);
|
||||||
|
|
||||||
S.Evaluate (SI, I, O);
|
S.Evaluate (SI, I, O);
|
||||||
S.Print (SI, I);
|
S.Print (SI, I);
|
||||||
Ada.Text_IO.Put_Line ("-------------------------------------------");
|
Ada.Text_IO.Put_Line ("-------------------------------------------");
|
||||||
S.Print (SI, O);
|
S.Print (SI, O);
|
||||||
|
|
||||||
|
Ada.Text_IO.Put_Line ("-------------------------------------------");
|
||||||
|
S.Run_Loop (SI, I);
|
||||||
|
S.Print (SI, I);
|
||||||
S.Close (SI);
|
S.Close (SI);
|
||||||
|
|
||||||
declare
|
declare
|
||||||
|
@ -33,6 +33,7 @@ package body H2.Scheme is
|
|||||||
Evaluation_Error: exception;
|
Evaluation_Error: exception;
|
||||||
Internal_Error: exception;
|
Internal_Error: exception;
|
||||||
IO_Error: exception;
|
IO_Error: exception;
|
||||||
|
Stream_End_Error: exception;
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
-- INTERNALLY-USED TYPES
|
-- INTERNALLY-USED TYPES
|
||||||
@ -47,14 +48,16 @@ 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 .. 6;
|
subtype Opcode_Type is Object_Integer range 0 .. 8;
|
||||||
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_Object: constant Opcode_Type := Opcode_Type'(1);
|
||||||
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(2);
|
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(2); -- (begin ...) and closure apply
|
||||||
Opcode_Evaluate_Syntax: constant Opcode_Type := Opcode_Type'(3);
|
Opcode_Evaluate_Syntax: constant Opcode_Type := Opcode_Type'(3);
|
||||||
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);
|
||||||
|
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(7);
|
||||||
|
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(8);
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
-- COMMON OBJECTS
|
-- COMMON OBJECTS
|
||||||
@ -945,7 +948,6 @@ Print_Object_Pointer ("Make_String Result - " & Source, Result);
|
|||||||
-- Make it GC-aweare. Protect Ptr
|
-- Make it GC-aweare. Protect Ptr
|
||||||
-- Link the symbol to the symbol table.
|
-- Link the symbol to the symbol table.
|
||||||
Interp.Symbol_Table := Make_Cons (Interp.Self, Ptr, Interp.Symbol_Table);
|
Interp.Symbol_Table := Make_Cons (Interp.Self, Ptr, Interp.Symbol_Table);
|
||||||
--Print_Object_Pointer ("Make_Symbol Result - " & Source, Result);
|
|
||||||
return Ptr;
|
return Ptr;
|
||||||
end Make_Symbol;
|
end Make_Symbol;
|
||||||
|
|
||||||
@ -1181,13 +1183,13 @@ Put_String (To_Thin_String_Pointer (Result));
|
|||||||
return Frame.Pointer_Slot(Frame_Return_Index);
|
return Frame.Pointer_Slot(Frame_Return_Index);
|
||||||
end Get_Frame_Return;
|
end Get_Frame_Return;
|
||||||
|
|
||||||
procedure Set_Frame_Return (Frame: in out Object_Pointer;
|
--procedure Set_Frame_Return (Frame: in out Object_Pointer;
|
||||||
Value: in Object_Pointer) is
|
-- Value: in Object_Pointer) is
|
||||||
pragma Inline (Set_Frame_Return);
|
-- pragma Inline (Set_Frame_Return);
|
||||||
pragma Assert (Is_Frame(Frame));
|
-- pragma Assert (Is_Frame(Frame));
|
||||||
begin
|
--begin
|
||||||
Frame.Pointer_Slot(Frame_Return_Index) := Value;
|
-- Frame.Pointer_Slot(Frame_Return_Index) := Value;
|
||||||
end Set_Frame_Return;
|
--end Set_Frame_Return;
|
||||||
|
|
||||||
procedure Chain_Frame_Return (Interp: in out Interpreter_Record;
|
procedure Chain_Frame_Return (Interp: in out Interpreter_Record;
|
||||||
Frame: in out Object_Pointer;
|
Frame: in out Object_Pointer;
|
||||||
@ -1195,12 +1197,12 @@ Put_String (To_Thin_String_Pointer (Result));
|
|||||||
pragma Inline (Chain_Frame_Return);
|
pragma Inline (Chain_Frame_Return);
|
||||||
pragma Assert (Is_Frame(Frame));
|
pragma Assert (Is_Frame(Frame));
|
||||||
|
|
||||||
Cons: Object_Pointer renames Frame.Pointer_Slot(Frame_Return_Index);
|
Ret_Head: Object_Pointer renames Frame.Pointer_Slot(Frame_Return_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
|
||||||
Cons := Make_Cons (Interp.Self, Value, Cons);
|
Ret_Head := Make_Cons (Interp.Self, Value, Ret_Head);
|
||||||
end Chain_Frame_Return;
|
end Chain_Frame_Return;
|
||||||
|
|
||||||
procedure Clear_Frame_Return (Frame: in out Object_Pointer) is
|
procedure Clear_Frame_Return (Frame: in out Object_Pointer) is
|
||||||
@ -1554,153 +1556,6 @@ Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Eleme
|
|||||||
--
|
--
|
||||||
--end Set_Output_Stream;
|
--end Set_Output_Stream;
|
||||||
|
|
||||||
procedure Read (Interp: in out Interpreter_Record;
|
|
||||||
Result: out Object_Pointer) is
|
|
||||||
|
|
||||||
procedure Fetch_Character is
|
|
||||||
begin
|
|
||||||
-- TODO: calculate Interp.Input.Row, Interp.Input.Column
|
|
||||||
if Interp.Input.Pos >= Interp.Input.Last then
|
|
||||||
if Interp.Input.Flags /= 0 then
|
|
||||||
-- An error has occurred or EOF has been reached previously.
|
|
||||||
-- Note calling this procedure after EOF results in an error.
|
|
||||||
Interp.Input.Iochar := (Error_Character, Object_Character'First);
|
|
||||||
--return;
|
|
||||||
raise IO_Error;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Interp.Input.Pos := Interp.Input.Data'First - 1;
|
|
||||||
begin
|
|
||||||
Read (Interp.Input.Stream.all, Interp.Input.Data, Interp.Input.Last);
|
|
||||||
exception
|
|
||||||
when others =>
|
|
||||||
-- The callee can raise an exception upon errors.
|
|
||||||
-- If an exception is raised, data read into the buffer
|
|
||||||
-- is also ignored.
|
|
||||||
Interp.Input.Flags := Interp.Input.Flags and IO_Error_Occurred;
|
|
||||||
Interp.Input.Iochar := (Error_Character, Object_Character'First);
|
|
||||||
--return;
|
|
||||||
raise IO_Error;
|
|
||||||
end;
|
|
||||||
if Interp.Input.Last < Interp.Input.Data'First then
|
|
||||||
-- The callee must read 0 bytes on EOF
|
|
||||||
Interp.Input.Flags := Interp.Input.Flags and IO_End_Reached;
|
|
||||||
Interp.Input.Iochar := (End_Character, Object_Character'First);
|
|
||||||
return;
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
Interp.Input.Pos := Interp.Input.Pos + 1;
|
|
||||||
Interp.Input.Iochar := (Normal_Character, Interp.Input.Data(Interp.Input.Pos));
|
|
||||||
end Fetch_Character;
|
|
||||||
|
|
||||||
function Is_White_Space (X: in Object_Character) return Standard.Boolean is
|
|
||||||
begin
|
|
||||||
return X = ' ' or else
|
|
||||||
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.HT)) or else
|
|
||||||
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.VT)) or else
|
|
||||||
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.CR)) or else
|
|
||||||
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)) or else
|
|
||||||
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.FF));
|
|
||||||
end Is_White_Space;
|
|
||||||
|
|
||||||
procedure Skip_Spaces is
|
|
||||||
C: IO_Character_Record renames Interp.Input.Iochar;
|
|
||||||
begin
|
|
||||||
loop
|
|
||||||
exit when C.Kind /= Normal_Character;
|
|
||||||
|
|
||||||
-- Normal character
|
|
||||||
if Is_White_Space(C.Value) then
|
|
||||||
Fetch_Character;
|
|
||||||
elsif C.Value = ';' then
|
|
||||||
-- Comment.
|
|
||||||
loop
|
|
||||||
Fetch_Character;
|
|
||||||
|
|
||||||
exit when C.Kind = End_Character; -- EOF before LF
|
|
||||||
|
|
||||||
if C.Kind = Normal_Character and then
|
|
||||||
C.Value = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)) then
|
|
||||||
Fetch_Character; -- Consume LF
|
|
||||||
exit;
|
|
||||||
end if;
|
|
||||||
end loop;
|
|
||||||
else
|
|
||||||
exit;
|
|
||||||
end if;
|
|
||||||
end loop;
|
|
||||||
end Skip_Spaces;
|
|
||||||
|
|
||||||
procedure Fetch_Token is
|
|
||||||
C: IO_Character_Record renames Interp.Input.Iochar;
|
|
||||||
begin
|
|
||||||
Skip_Spaces;
|
|
||||||
if C.Kind /= Normal_Character then
|
|
||||||
Token.Set (Interp, End_Token, "");
|
|
||||||
return;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
case C.Value is
|
|
||||||
when '(' =>
|
|
||||||
Token.Set (Interp, Left_Parenthesis_Token, "(");
|
|
||||||
Fetch_Character;
|
|
||||||
|
|
||||||
when ')' =>
|
|
||||||
Token.Set (Interp, Right_Parenthesis_Token, ")");
|
|
||||||
Fetch_Character;
|
|
||||||
|
|
||||||
when ''' =>
|
|
||||||
Token.Set (Interp, Single_Quote_Token, "'");
|
|
||||||
Fetch_Character;
|
|
||||||
|
|
||||||
when '"' =>
|
|
||||||
Token.Set (Interp, String_Token, "'");
|
|
||||||
Fetch_Character;
|
|
||||||
-- TODO:
|
|
||||||
|
|
||||||
when '#' =>
|
|
||||||
Fetch_Character;
|
|
||||||
-- TODO: t, false, etc
|
|
||||||
|
|
||||||
when others =>
|
|
||||||
Token.Set (Interp, Identifier_Token, "");
|
|
||||||
loop
|
|
||||||
Token.Append_Character (Interp, C.Value);
|
|
||||||
Fetch_Character;
|
|
||||||
--exit when not Is_Ident_Char(C.Value);
|
|
||||||
if C.Value = '(' or else C.Value = ')' or else
|
|
||||||
C.Value = ''' or else C.Value = '"' or else
|
|
||||||
C.Value = '#' or else C.Value = ';' or else
|
|
||||||
Is_White_Space(C.Value) then
|
|
||||||
exit;
|
|
||||||
end if;
|
|
||||||
end loop;
|
|
||||||
end case;
|
|
||||||
|
|
||||||
Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>> Token: " & Interp.Token.Value.Ptr(1..Interp.Token.Value.Last));
|
|
||||||
end Fetch_Token;
|
|
||||||
|
|
||||||
procedure Read_Atom (Atom: out Object_Pointer) is
|
|
||||||
begin
|
|
||||||
null;
|
|
||||||
end Read_Atom;
|
|
||||||
|
|
||||||
Stack: Object_Pointer;
|
|
||||||
Opcode: Object_Integer;
|
|
||||||
Operand: Object_Pointer;
|
|
||||||
|
|
||||||
begin
|
|
||||||
Fetch_Character;
|
|
||||||
loop
|
|
||||||
Fetch_Token;
|
|
||||||
exit when Interp.Token.Kind = End_Token;
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
exception
|
|
||||||
when IO_Error =>
|
|
||||||
Text_IO.Put_Line ("****************************** INPUT ERROR...");
|
|
||||||
end Read;
|
|
||||||
|
|
||||||
procedure Print (Interp: in out Interpreter_Record;
|
procedure Print (Interp: in out Interpreter_Record;
|
||||||
Source: in Object_Pointer) is
|
Source: in Object_Pointer) is
|
||||||
|
|
||||||
@ -1945,6 +1800,7 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec
|
|||||||
P: Object_Pointer;
|
P: Object_Pointer;
|
||||||
B: Object_Pointer;
|
B: Object_Pointer;
|
||||||
L: Object_Pointer;
|
L: Object_Pointer;
|
||||||
|
Resultx: Object_Pointer;
|
||||||
begin
|
begin
|
||||||
--(define x 10)
|
--(define x 10)
|
||||||
--Result := Make_Cons (
|
--Result := Make_Cons (
|
||||||
@ -2007,16 +1863,24 @@ begin
|
|||||||
)
|
)
|
||||||
);
|
);
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Z := Make_Cons (
|
Z := Make_Cons (
|
||||||
Interp.Self,
|
Interp.Self,
|
||||||
Make_Symbol (Interp.Self, "begin"),
|
Make_Symbol (Interp.Self, "begin"),
|
||||||
Y
|
Make_COns (Interp.Self, Y, Nil_Pointer)
|
||||||
|
);
|
||||||
|
|
||||||
|
B := Make_Cons (
|
||||||
|
Interp.Self,
|
||||||
|
Make_Symbol (Interp.Self, "begin"),
|
||||||
|
Make_Cons (Interp.Self, Z, Nil_Pointer)
|
||||||
);
|
);
|
||||||
|
|
||||||
Result := Make_Cons (
|
Result := Make_Cons (
|
||||||
Interp.Self,
|
Interp.Self,
|
||||||
Make_Symbol (Interp.Self, "begin"),
|
Make_Symbol (Interp.Self, "+"),
|
||||||
Make_Cons (Interp.Self, Z, Nil_Pointer)
|
Make_Cons (Interp.Self, Integer_To_Pointer(88), Make_Cons (Interp.Self, B, Nil_Pointer))
|
||||||
);
|
);
|
||||||
|
|
||||||
-- (lambda (x y) (+ x y))
|
-- (lambda (x y) (+ x y))
|
||||||
@ -2090,11 +1954,8 @@ end Make_Test_Object;
|
|||||||
return Integer_To_Pointer(Opcode);
|
return Integer_To_Pointer(Opcode);
|
||||||
end Opcode_To_Pointer;
|
end Opcode_To_Pointer;
|
||||||
|
|
||||||
procedure Evaluate (Interp: in out Interpreter_Record;
|
procedure Push_Frame (Interp: in out Interpreter_Record;
|
||||||
Source: in Object_Pointer;
|
Opcode: in Opcode_Type;
|
||||||
Result: out Object_Pointer) is
|
|
||||||
|
|
||||||
procedure Push_Frame (Opcode: in Opcode_Type;
|
|
||||||
Operand: in Object_Pointer) is
|
Operand: in Object_Pointer) is
|
||||||
pragma Inline (Push_Frame);
|
pragma Inline (Push_Frame);
|
||||||
begin
|
begin
|
||||||
@ -2112,7 +1973,7 @@ end Make_Test_Object;
|
|||||||
-- Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop
|
-- Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop
|
||||||
--end Pop_Frame;
|
--end Pop_Frame;
|
||||||
|
|
||||||
procedure Pop_Frame is
|
procedure Pop_Frame (Interp: in out Interpreter_Record) is
|
||||||
pragma Inline (Pop_Frame);
|
pragma Inline (Pop_Frame);
|
||||||
begin
|
begin
|
||||||
pragma Assert (Interp.Stack /= Nil_Pointer);
|
pragma Assert (Interp.Stack /= Nil_Pointer);
|
||||||
@ -2120,6 +1981,10 @@ end Make_Test_Object;
|
|||||||
Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop
|
Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop
|
||||||
end Pop_Frame;
|
end Pop_Frame;
|
||||||
|
|
||||||
|
procedure Execute (Interp: in out Interpreter_Record) is
|
||||||
|
|
||||||
|
LC: IO_Character_Record renames Interp.Input.Iochar;
|
||||||
|
|
||||||
procedure Evaluate_Group is
|
procedure Evaluate_Group is
|
||||||
pragma Inline (Evaluate_Group);
|
pragma Inline (Evaluate_Group);
|
||||||
|
|
||||||
@ -2144,6 +2009,10 @@ end Make_Test_Object;
|
|||||||
Text_IO.Put_Line ("$$$$..................FUCKING CDR. FOR GROUP....................$$$$");
|
Text_IO.Put_Line ("$$$$..................FUCKING CDR. FOR GROUP....................$$$$");
|
||||||
-- raise Syntax_Error;
|
-- raise Syntax_Error;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
-- Change the operand to a mark object so that the call to this
|
||||||
|
-- procedure after the evaluation of the last car goes to the
|
||||||
|
-- Mark_Object case.
|
||||||
Set_Frame_Operand (Interp.Stack, Interp.Mark);
|
Set_Frame_Operand (Interp.Stack, Interp.Mark);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
@ -2151,12 +2020,17 @@ end Make_Test_Object;
|
|||||||
Clear_Frame_Return (Interp.Stack);
|
Clear_Frame_Return (Interp.Stack);
|
||||||
|
|
||||||
-- Arrange to evaluate the current expression
|
-- Arrange to evaluate the current expression
|
||||||
Push_Frame (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_Return (Interp.Stack);
|
||||||
Pop_Frame; -- Done;
|
Pop_Frame (Interp); -- Done
|
||||||
Set_Frame_Return (Interp.Stack, Operand);
|
|
||||||
|
-- There must be only 1 return value chained in the Group frame.
|
||||||
|
pragma Assert (Get_Cdr(Operand) = Nil_Pointer);
|
||||||
|
|
||||||
|
-- Transfer the only return value to the upper chain
|
||||||
|
Chain_Frame_Return (Interp, Interp.Stack, Get_Car(Operand));
|
||||||
|
|
||||||
when others =>
|
when others =>
|
||||||
raise Internal_Error;
|
raise Internal_Error;
|
||||||
@ -2186,6 +2060,7 @@ end Make_Test_Object;
|
|||||||
if Car = null then
|
if Car = null then
|
||||||
-- unbound
|
-- unbound
|
||||||
Text_IO.Put_Line ("Unbound symbol....");
|
Text_IO.Put_Line ("Unbound symbol....");
|
||||||
|
Print (Interp, Operand);
|
||||||
raise Evaluation_Error;
|
raise Evaluation_Error;
|
||||||
else
|
else
|
||||||
-- symbol found in the environment
|
-- symbol found in the environment
|
||||||
@ -2210,13 +2085,12 @@ end Make_Test_Object;
|
|||||||
-- (begin . 10)
|
-- (begin . 10)
|
||||||
Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
|
Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
|
||||||
raise Syntax_Error;
|
raise Syntax_Error;
|
||||||
--Pop_Frame; -- Done
|
--Pop_Frame (Interp); -- Done
|
||||||
|
|
||||||
else
|
else
|
||||||
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
|
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
|
||||||
Set_Frame_Operand (Interp.Stack, Operand);
|
Set_Frame_Operand (Interp.Stack, Operand);
|
||||||
|
|
||||||
|
|
||||||
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
|
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
|
||||||
-- I call Evaluate_Group for optimization here.
|
-- I call Evaluate_Group for optimization here.
|
||||||
Evaluate_Group; -- for optimization only. not really needed.
|
Evaluate_Group; -- for optimization only. not really needed.
|
||||||
@ -2238,26 +2112,26 @@ end Make_Test_Object;
|
|||||||
-- (lambda . 10)
|
-- (lambda . 10)
|
||||||
Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
|
Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
|
||||||
raise Syntax_Error;
|
raise Syntax_Error;
|
||||||
--Pop_Frame; -- Done
|
--Pop_Frame (Interp); -- Done
|
||||||
else
|
else
|
||||||
if not Is_Cons(Get_Car(Operand)) then
|
if not Is_Cons(Get_Car(Operand)) then
|
||||||
Text_IO.Put_Line ("INVALID PARRAMETER LIST");
|
Text_IO.Put_Line ("INVALID PARRAMETER LIST");
|
||||||
raise Syntax_Error;
|
raise Syntax_Error;
|
||||||
--Pop_Frame; -- Done
|
--Pop_Frame (Interp); -- Done
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
--Print (Interp, Get_Cdr(Operand));
|
--Print (Interp, Get_Cdr(Operand));
|
||||||
if not Is_Cons(Get_Cdr(Operand)) then
|
if not Is_Cons(Get_Cdr(Operand)) then
|
||||||
Text_IO.Put_Line ("NO BODY");
|
Text_IO.Put_Line ("NO BODY");
|
||||||
raise Syntax_Error;
|
raise Syntax_Error;
|
||||||
--Pop_Frame; -- Done
|
--Pop_Frame (Interp); -- Done
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Closure: Object_Pointer;
|
Closure: Object_Pointer;
|
||||||
begin
|
begin
|
||||||
Closure := Make_Closure (Interp.Self, Operand, Interp.Environment);
|
Closure := Make_Closure (Interp.Self, Operand, Interp.Environment);
|
||||||
Pop_Frame; -- Done
|
Pop_Frame (Interp); -- Done
|
||||||
Chain_Frame_Return (Interp, Interp.Stack, Closure);
|
Chain_Frame_Return (Interp, Interp.Stack, Closure);
|
||||||
end;
|
end;
|
||||||
end if;
|
end if;
|
||||||
@ -2310,7 +2184,7 @@ end Make_Test_Object;
|
|||||||
|
|
||||||
-- Arrange to evaluate the car object
|
-- Arrange to evaluate the car object
|
||||||
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
|
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
|
||||||
Push_Frame (Opcode_Evaluate_Object, Car);
|
Push_Frame (Interp, Opcode_Evaluate_Object, Car);
|
||||||
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;
|
||||||
@ -2327,8 +2201,8 @@ end Make_Test_Object;
|
|||||||
-- This should be faster than Popping the current frame and pushing
|
-- This should be faster than Popping the current frame and pushing
|
||||||
-- a new frame.
|
-- a new frame.
|
||||||
-- Envir := Get_Frame_Environment(Interp.Stack);
|
-- Envir := Get_Frame_Environment(Interp.Stack);
|
||||||
-- Pop_Frame (Interp.Stack); -- done
|
-- Pop_Frame (Interp); -- done
|
||||||
-- Push_Frame (Interp.Stack, Opcode_Apply, Operand, Envir);
|
-- Push_Frame (Interp, Opcode_Apply, Operand, Envir);
|
||||||
Clear_Frame_Return (Interp.Stack);
|
Clear_Frame_Return (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);
|
||||||
@ -2340,13 +2214,12 @@ end Make_Test_Object;
|
|||||||
return;
|
return;
|
||||||
|
|
||||||
<<Literal>>
|
<<Literal>>
|
||||||
Pop_Frame; -- 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_Return (Interp, Interp.Stack, Operand);
|
||||||
end Evaluate_Object;
|
end Evaluate_Object;
|
||||||
|
|
||||||
|
|
||||||
procedure Evaluate_Syntax is
|
procedure Evaluate_Syntax is
|
||||||
pragma Inline (Evaluate_Syntax);
|
pragma Inline (Evaluate_Syntax);
|
||||||
Scode: Syntax_Code;
|
Scode: Syntax_Code;
|
||||||
@ -2354,6 +2227,7 @@ Print (Interp, Operand);
|
|||||||
Scode := Get_Car(Get_Frame_Operand(Interp.Stack)).Scode;
|
Scode := Get_Car(Get_Frame_Operand(Interp.Stack)).Scode;
|
||||||
case Scode is
|
case Scode is
|
||||||
when Begin_Syntax =>
|
when Begin_Syntax =>
|
||||||
|
-- not used. Evaluate_Group is used instead.
|
||||||
null;
|
null;
|
||||||
when Define_Syntax =>
|
when Define_Syntax =>
|
||||||
Text_IO.Put_Line ("define syntax");
|
Text_IO.Put_Line ("define syntax");
|
||||||
@ -2377,13 +2251,13 @@ Print (Interp, Operand);
|
|||||||
|
|
||||||
procedure Apply_Car_Procedure is
|
procedure Apply_Car_Procedure is
|
||||||
begin
|
begin
|
||||||
Pop_Frame; -- Done with the current frame
|
Pop_Frame (Interp); -- Done with the current frame
|
||||||
Chain_Frame_Return (Interp, Interp.Stack, Get_Car(Args));
|
Chain_Frame_Return (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; -- Done with the current frame
|
Pop_Frame (Interp); -- Done with the current frame
|
||||||
Chain_Frame_Return (Interp, Interp.Stack, Get_Cdr(Args));
|
Chain_Frame_Return (Interp, Interp.Stack, Get_Cdr(Args));
|
||||||
end Apply_Cdr_Procedure;
|
end Apply_Cdr_Procedure;
|
||||||
|
|
||||||
@ -2397,13 +2271,14 @@ Print (Interp, Operand);
|
|||||||
-- if something else, error
|
-- if something else, error
|
||||||
Car := Get_Car(Ptr);
|
Car := Get_Car(Ptr);
|
||||||
if not Is_Integer(Car) then
|
if not Is_Integer(Car) then
|
||||||
|
Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
|
||||||
raise Evaluation_Error;
|
raise Evaluation_Error;
|
||||||
end if;
|
end if;
|
||||||
Num := Num + Pointer_To_Integer(Car);
|
Num := Num + Pointer_To_Integer(Car);
|
||||||
Ptr := Get_Cdr(Ptr);
|
Ptr := Get_Cdr(Ptr);
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
Pop_Frame; -- 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_Return (Interp, Interp.Stack, Integer_To_Pointer(Num));
|
||||||
end Apply_Add_Procedure;
|
end Apply_Add_Procedure;
|
||||||
|
|
||||||
@ -2431,7 +2306,7 @@ Print (Interp, Operand);
|
|||||||
end loop;
|
end loop;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Pop_Frame; -- 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_Return (Interp, Interp.Stack, Integer_To_Pointer(Num));
|
||||||
end Apply_Subtract_Procedure;
|
end Apply_Subtract_Procedure;
|
||||||
|
|
||||||
@ -2541,9 +2416,256 @@ Print (Interp, Operand);
|
|||||||
end case;
|
end case;
|
||||||
end Apply;
|
end Apply;
|
||||||
|
|
||||||
procedure Read_Object is
|
procedure Fetch_Character is
|
||||||
begin
|
begin
|
||||||
null;
|
-- TODO: calculate Interp.Input.Row, Interp.Input.Column
|
||||||
|
if Interp.Input.Pos >= Interp.Input.Last then
|
||||||
|
if Interp.Input.Flags /= 0 then
|
||||||
|
-- An error has occurred or EOF has been reached previously.
|
||||||
|
-- Note calling this procedure after EOF results in an error.
|
||||||
|
Interp.Input.Iochar := (Error_Character, Object_Character'First);
|
||||||
|
--return;
|
||||||
|
raise IO_Error;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Interp.Input.Pos := Interp.Input.Data'First - 1;
|
||||||
|
begin
|
||||||
|
Read (Interp.Input.Stream.all, Interp.Input.Data, Interp.Input.Last);
|
||||||
|
exception
|
||||||
|
when others =>
|
||||||
|
-- The callee can raise an exception upon errors.
|
||||||
|
-- If an exception is raised, data read into the buffer
|
||||||
|
-- is also ignored.
|
||||||
|
Interp.Input.Flags := Interp.Input.Flags and IO_Error_Occurred;
|
||||||
|
Interp.Input.Iochar := (Error_Character, Object_Character'First);
|
||||||
|
--return;
|
||||||
|
raise IO_Error;
|
||||||
|
end;
|
||||||
|
if Interp.Input.Last < Interp.Input.Data'First then
|
||||||
|
-- The callee must read 0 bytes on EOF
|
||||||
|
Interp.Input.Flags := Interp.Input.Flags and IO_End_Reached;
|
||||||
|
Interp.Input.Iochar := (End_Character, Object_Character'First);
|
||||||
|
return;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
Interp.Input.Pos := Interp.Input.Pos + 1;
|
||||||
|
Interp.Input.Iochar := (Normal_Character, Interp.Input.Data(Interp.Input.Pos));
|
||||||
|
end Fetch_Character;
|
||||||
|
|
||||||
|
function Is_White_Space (X: in Object_Character) return Standard.Boolean is
|
||||||
|
begin
|
||||||
|
return X = ' ' or else
|
||||||
|
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.HT)) or else
|
||||||
|
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.VT)) or else
|
||||||
|
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.CR)) or else
|
||||||
|
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)) or else
|
||||||
|
X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.FF));
|
||||||
|
end Is_White_Space;
|
||||||
|
|
||||||
|
procedure Skip_Spaces_And_Comments is
|
||||||
|
begin
|
||||||
|
loop
|
||||||
|
exit when LC.Kind /= Normal_Character;
|
||||||
|
|
||||||
|
-- Normal character
|
||||||
|
if Is_White_Space(LC.Value) then
|
||||||
|
Fetch_Character;
|
||||||
|
elsif LC.Value = ';' then
|
||||||
|
-- Comment.
|
||||||
|
loop
|
||||||
|
Fetch_Character;
|
||||||
|
|
||||||
|
exit when LC.Kind = End_Character; -- EOF before LF
|
||||||
|
|
||||||
|
if LC.Kind = Normal_Character and then
|
||||||
|
LC.Value = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)) then
|
||||||
|
Fetch_Character; -- Read the next character after LF
|
||||||
|
exit;
|
||||||
|
end if;
|
||||||
|
end loop;
|
||||||
|
else
|
||||||
|
exit;
|
||||||
|
end if;
|
||||||
|
end loop;
|
||||||
|
end Skip_Spaces_And_Comments;
|
||||||
|
|
||||||
|
procedure Fetch_Token is
|
||||||
|
begin
|
||||||
|
if not Interp.LC_Unfetched then
|
||||||
|
Fetch_Character;
|
||||||
|
else
|
||||||
|
-- Reuse the last character unfetched
|
||||||
|
Interp.LC_Unfetched := Standard.False;
|
||||||
|
end if;
|
||||||
|
Skip_Spaces_And_Comments;
|
||||||
|
if LC.Kind /= Normal_Character then
|
||||||
|
Token.Set (Interp, End_Token, "");
|
||||||
|
return;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- TODO: Pass Token Location when calling Token.Set
|
||||||
|
case LC.Value is
|
||||||
|
when '(' =>
|
||||||
|
Token.Set (Interp, Left_Parenthesis_Token, "(");
|
||||||
|
|
||||||
|
when ')' =>
|
||||||
|
Token.Set (Interp, Right_Parenthesis_Token, ")");
|
||||||
|
|
||||||
|
when '.' =>
|
||||||
|
Token.Set (Interp, Period_Token, ".");
|
||||||
|
|
||||||
|
when ''' =>
|
||||||
|
Token.Set (Interp, Single_Quote_Token, "'");
|
||||||
|
|
||||||
|
when '"' =>
|
||||||
|
Fetch_Character;
|
||||||
|
Token.Set (Interp, String_Token, "");
|
||||||
|
loop
|
||||||
|
if LC.Kind /= Normal_Character then
|
||||||
|
-- String ended prematurely.
|
||||||
|
-- TODO: Set Error code, Error Number.... Error location
|
||||||
|
raise Syntax_Error;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
if LC.Value = '\' then
|
||||||
|
Fetch_Character;
|
||||||
|
if LC.Kind /= Normal_Character then
|
||||||
|
-- String ended prematurely.
|
||||||
|
-- TODO: Set Error code, Error Number.... Error location
|
||||||
|
raise Syntax_Error;
|
||||||
|
end if;
|
||||||
|
-- TODO: escape letters??? \n \r \\ etc....
|
||||||
|
Token.Append_Character (Interp, LC.Value);
|
||||||
|
elsif LC.Value = '"' then
|
||||||
|
exit;
|
||||||
|
else
|
||||||
|
Token.Append_Character (Interp, LC.Value);
|
||||||
|
Fetch_Character;
|
||||||
|
end if;
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
-- TODO:
|
||||||
|
|
||||||
|
when '#' =>
|
||||||
|
Fetch_Character;
|
||||||
|
-- TODO: t, false, etc
|
||||||
|
|
||||||
|
when others =>
|
||||||
|
Token.Set (Interp, Identifier_Token, "");
|
||||||
|
loop
|
||||||
|
Token.Append_Character (Interp, LC.Value);
|
||||||
|
Fetch_Character;
|
||||||
|
--exit when not Is_Ident_Char(C.Value);
|
||||||
|
-- TODO: more characters
|
||||||
|
if 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;
|
||||||
|
end loop;
|
||||||
|
end case;
|
||||||
|
|
||||||
|
Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>> Token: " & Interp.Token.Value.Ptr(1..Interp.Token.Value.Last));
|
||||||
|
end Fetch_Token;
|
||||||
|
|
||||||
|
procedure Read_List is
|
||||||
|
V: Object_Pointer;
|
||||||
|
Period: Standard.Boolean := Standard.False;
|
||||||
|
begin
|
||||||
|
<<Start_Over>>
|
||||||
|
Fetch_Token;
|
||||||
|
|
||||||
|
case Interp.Token.Kind is
|
||||||
|
when End_Token =>
|
||||||
|
Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
|
||||||
|
raise Syntax_Error;
|
||||||
|
|
||||||
|
when Left_Parenthesis_Token =>
|
||||||
|
Push_Frame (Interp, Opcode_Read_List, Nil_Pointer);
|
||||||
|
|
||||||
|
when Right_Parenthesis_Token =>
|
||||||
|
V := Get_Frame_Return(Interp.Stack);
|
||||||
|
if V /= Nil_Pointer then
|
||||||
|
V := Reverse_Cons(V); -- TODO: GC
|
||||||
|
end if;
|
||||||
|
Pop_Frame (Interp);
|
||||||
|
Chain_Frame_Return (Interp, Interp.Stack, V);
|
||||||
|
|
||||||
|
when Period_Token =>
|
||||||
|
V := Get_Frame_Return(Interp.Stack);
|
||||||
|
if V = Nil_Pointer then
|
||||||
|
-- . immediately after (
|
||||||
|
raise Syntax_Error;
|
||||||
|
else
|
||||||
|
Period := Standard.True;
|
||||||
|
goto Start_Over;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
when String_Token =>
|
||||||
|
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
|
||||||
|
-- TODO: make V gc-aware
|
||||||
|
if Period then
|
||||||
|
|
||||||
|
else
|
||||||
|
Chain_Frame_Return (Interp, Interp.Stack, V);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
when Identifier_Token =>
|
||||||
|
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
|
||||||
|
-- TODO: make V gc-aware
|
||||||
|
if Period then
|
||||||
|
else
|
||||||
|
Chain_Frame_Return (Interp, Interp.Stack, V);
|
||||||
|
end if
|
||||||
|
|
||||||
|
when others =>
|
||||||
|
-- TODO: set various error info
|
||||||
|
raise Syntax_Error;
|
||||||
|
end case;
|
||||||
|
end Read_List;
|
||||||
|
|
||||||
|
procedure Close_List is
|
||||||
|
V: Object_Pointer;
|
||||||
|
begin
|
||||||
|
V := Get_Frame_Return(Interp.Stack);
|
||||||
|
pragma Assert (Get_Cdr(V) = Nil_Pointer);
|
||||||
|
Pop_Frame (Interp); -- Done with the current frame
|
||||||
|
Chain_Frame_Return (Interp, Interp.Stack, Get_Car(V));
|
||||||
|
end Close_List;
|
||||||
|
|
||||||
|
procedure Read_Object is
|
||||||
|
V: Object_Pointer;
|
||||||
|
begin
|
||||||
|
Fetch_Token;
|
||||||
|
|
||||||
|
case Interp.Token.Kind is
|
||||||
|
when End_Token =>
|
||||||
|
Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
|
||||||
|
raise Stream_End_Error;
|
||||||
|
|
||||||
|
when Left_Parenthesis_Token =>
|
||||||
|
Set_Frame_Opcode (Interp.Stack, Opcode_Close_List);
|
||||||
|
Push_Frame (Interp, Opcode_Read_List, Nil_Pointer);
|
||||||
|
|
||||||
|
when String_Token =>
|
||||||
|
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
|
||||||
|
-- TODO: make V gc-aware
|
||||||
|
Pop_Frame (Interp); -- Done with the current frame
|
||||||
|
Chain_Frame_Return (Interp, Interp.Stack, V);
|
||||||
|
|
||||||
|
when Identifier_Token =>
|
||||||
|
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
|
||||||
|
-- TODO: make V gc-aware
|
||||||
|
Pop_Frame (Interp); -- Done with the current frame
|
||||||
|
Chain_Frame_Return (Interp, Interp.Stack, V);
|
||||||
|
|
||||||
|
when others =>
|
||||||
|
-- TODO: set various error info
|
||||||
|
raise Syntax_Error;
|
||||||
|
end case;
|
||||||
end Read_Object;
|
end Read_Object;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
@ -2605,22 +2727,14 @@ Print (Interp, Operand);
|
|||||||
-- The apply operation produces the final result and sets it to the
|
-- The apply operation produces the final result and sets it to the
|
||||||
-- parent frame while removing the apply frame.
|
-- parent frame while removing the apply frame.
|
||||||
-- -----------------------------------------------------------------
|
-- -----------------------------------------------------------------
|
||||||
-- top/bottom| Opcode_Exit | Nil | 3
|
-- top/bottom| Opcode_Exit | Nil | (3)
|
||||||
|
|
||||||
|
-- The caller must push some frames before calling this procedure
|
||||||
Interp.Stack := Nil_Pointer;
|
pragma Assert (Interp.Stack /= Nil_Pointer);
|
||||||
|
|
||||||
-- Push a pseudo-frame to terminate the evaluation loop
|
|
||||||
Push_Frame (Opcode_Exit, Nil_Pointer);
|
|
||||||
|
|
||||||
-- Push the actual frame for evaluation
|
|
||||||
Push_Frame (Opcode_Evaluate_Object, Source);
|
|
||||||
|
|
||||||
loop
|
loop
|
||||||
case Get_Frame_Opcode(Interp.Stack) is
|
case Get_Frame_Opcode(Interp.Stack) is
|
||||||
when Opcode_Exit =>
|
when Opcode_Exit =>
|
||||||
Result := Get_Frame_Return (Interp.Stack);
|
|
||||||
Pop_Frame;
|
|
||||||
exit;
|
exit;
|
||||||
|
|
||||||
when Opcode_Evaluate_Object =>
|
when Opcode_Evaluate_Object =>
|
||||||
@ -2640,24 +2754,98 @@ Print (Interp, Operand);
|
|||||||
|
|
||||||
when Opcode_Read_Object =>
|
when Opcode_Read_Object =>
|
||||||
Read_Object;
|
Read_Object;
|
||||||
|
|
||||||
|
when Opcode_Read_List =>
|
||||||
|
Read_List;
|
||||||
|
|
||||||
|
when Opcode_Close_List =>
|
||||||
|
Close_List;
|
||||||
end case;
|
end case;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
-- the stack must be empty when the loop is terminated
|
-- the stack must be empty when the loop is terminated
|
||||||
pragma Assert (Interp.Stack = Nil_Pointer);
|
--pragma Assert (Interp.Stack = Nil_Pointer);
|
||||||
|
|
||||||
exception
|
exception
|
||||||
|
when Stream_End_Error =>
|
||||||
|
raise;
|
||||||
|
|
||||||
when others =>
|
when others =>
|
||||||
Text_IO.Put_Line ("EXCEPTION OCCURRED");
|
Text_IO.Put_Line ("EXCEPTION OCCURRED");
|
||||||
-- TODO: restore stack frame???
|
-- TODO: restore stack frame???
|
||||||
-- TODO: restore envirronemtn frame???
|
-- TODO: restore envirronemtn frame???
|
||||||
|
raise;
|
||||||
|
end Execute;
|
||||||
|
|
||||||
|
procedure Evaluate (Interp: in out Interpreter_Record;
|
||||||
|
Source: in Object_Pointer;
|
||||||
|
Result: out Object_Pointer) is
|
||||||
|
begin
|
||||||
|
|
||||||
|
pragma Assert (Interp.Stack = Nil_Pointer);
|
||||||
|
Interp.Stack := Nil_Pointer;
|
||||||
|
|
||||||
|
-- Push a pseudo-frame to terminate the evaluation loop
|
||||||
|
Push_Frame (Interp, Opcode_Exit, Nil_Pointer);
|
||||||
|
|
||||||
|
-- Push the actual frame for evaluation
|
||||||
|
Push_Frame (Interp, Opcode_Evaluate_Object, Source);
|
||||||
|
|
||||||
|
Execute (Interp);
|
||||||
|
|
||||||
|
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);
|
||||||
|
|
||||||
|
Result := Get_Frame_Return (Interp.Stack);
|
||||||
|
-- There must be only 1 value chained to the top-level frame
|
||||||
|
-- once evaluation is over.
|
||||||
|
pragma Assert (Get_Cdr(Result) = Nil_Pointer);
|
||||||
|
-- Get the only value chained
|
||||||
|
Result := Get_Car(Result);
|
||||||
|
Pop_Frame (Interp);
|
||||||
|
|
||||||
|
pragma Assert (Interp.Stack = Nil_Pointer);
|
||||||
|
|
||||||
end Evaluate;
|
end Evaluate;
|
||||||
|
|
||||||
procedure Run_Loop (Interp: in out Interpreter_Record;
|
procedure Run_Loop (Interp: in out Interpreter_Record;
|
||||||
Result: out Object_Pointer) is
|
Result: out Object_Pointer) is
|
||||||
-- standard read-eval-print loop
|
-- standard read-eval-print loop
|
||||||
begin
|
begin
|
||||||
null;
|
Result := Nil_Pointer;
|
||||||
|
|
||||||
|
loop
|
||||||
|
pragma Assert (Interp.Stack = Nil_Pointer);
|
||||||
|
Interp.Stack := Nil_Pointer;
|
||||||
|
|
||||||
|
Push_Frame (Interp, Opcode_Exit, Nil_Pointer);
|
||||||
|
--Push_Frame (Interp, Opcode_Print, Nil_Pointer);
|
||||||
|
--Push_Frame (Interp, Opcode_Evaluate_Object, Nil_Pointer);
|
||||||
|
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
|
||||||
|
|
||||||
|
Execute (Interp);
|
||||||
|
|
||||||
|
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);
|
||||||
|
|
||||||
|
-- TODO: this result must be kept at some where that GC dowsn't sweep.
|
||||||
|
Result := Get_Frame_Return (Interp.Stack);
|
||||||
|
pragma Assert (Get_Cdr(Result) = Nil_Pointer);
|
||||||
|
Result := Get_Car(Result);
|
||||||
|
Pop_Frame (Interp);
|
||||||
|
|
||||||
|
Ada.Text_IO.Put ("REsULT>>>>>");
|
||||||
|
Print (Interp, Result);
|
||||||
|
pragma Assert (Interp.Stack = Nil_Pointer);
|
||||||
|
Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> LOOP ITERATION XXXXXX CHECKPOINT");
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
exception
|
||||||
|
when Stream_End_Error =>
|
||||||
|
-- this is not a real error. this indicates the end of input stream.
|
||||||
|
Text_IO.Put_LINE ("=== BYE ===");
|
||||||
|
|
||||||
|
when others =>
|
||||||
|
TEXT_IO.PUT_LINE ("ERROR ERROR ERROR");
|
||||||
|
raise;
|
||||||
end Run_Loop;
|
end Run_Loop;
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
@ -333,7 +333,6 @@ package H2.Scheme is
|
|||||||
Iochar: IO_Character_Record; -- the last character read.
|
Iochar: IO_Character_Record; -- the last character read.
|
||||||
end record;
|
end record;
|
||||||
|
|
||||||
|
|
||||||
-- -----------------------------------------------------------------------------
|
-- -----------------------------------------------------------------------------
|
||||||
|
|
||||||
type Trait_Mask is mod 2 ** System.Word_Size;
|
type Trait_Mask is mod 2 ** System.Word_Size;
|
||||||
@ -402,8 +401,8 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec
|
|||||||
Stream: in out Stream_Record'Class);
|
Stream: in out Stream_Record'Class);
|
||||||
|
|
||||||
-- Source must be open for Read() to work.
|
-- Source must be open for Read() to work.
|
||||||
procedure Read (Interp: in out Interpreter_Record;
|
--procedure Read (Interp: in out Interpreter_Record;
|
||||||
Result: out Object_Pointer);
|
-- Result: out Object_Pointer);
|
||||||
|
|
||||||
procedure Evaluate (Interp: in out Interpreter_Record;
|
procedure Evaluate (Interp: in out Interpreter_Record;
|
||||||
Source: in Object_Pointer;
|
Source: in Object_Pointer;
|
||||||
@ -444,6 +443,7 @@ private
|
|||||||
Identifier_Token,
|
Identifier_Token,
|
||||||
Left_Parenthesis_Token,
|
Left_Parenthesis_Token,
|
||||||
Right_Parenthesis_Token,
|
Right_Parenthesis_Token,
|
||||||
|
Period_Token,
|
||||||
Single_Quote_Token,
|
Single_Quote_Token,
|
||||||
String_Token
|
String_Token
|
||||||
);
|
);
|
||||||
@ -475,6 +475,7 @@ private
|
|||||||
Input: IO_Pointer := null;
|
Input: IO_Pointer := null;
|
||||||
|
|
||||||
Token: Token_Record;
|
Token: Token_Record;
|
||||||
|
LC_Unfetched: Standard.Boolean := Standard.False;
|
||||||
end record;
|
end record;
|
||||||
|
|
||||||
end H2.Scheme;
|
end H2.Scheme;
|
||||||
|
Loading…
Reference in New Issue
Block a user