hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
d1af233db4
hcl/lib/h2-scheme-execute.adb

1024 lines
32 KiB
Ada
Raw Blame History

separate (H2.Scheme)
procedure Execute (Interp: in out Interpreter_Record) is
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
pragma Inline (Evaluate_Group);
Operand: aliased Object_Pointer;
Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer;
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access);
Push_Top (Interp, Cdr'Unchecked_Access);
Operand := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Normal_Pointer(Operand));
case Operand.Tag is
when Cons_Object =>
Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand);
if Is_Cons(Cdr) then
-- Let the current frame remember the next expression list
Set_Frame_Operand (Interp.Stack, Cdr);
else
if Cdr /= Nil_Pointer then
-- The last CDR is not Nil.
Ada.Text_IO.Put_Line ("$$$$..................FUCKING CDR. FOR GROUP....................$$$$");
-- raise Syntax_Error;
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);
end if;
-- Clear the return value from the previous expression.
Clear_Frame_Result (Interp.Stack);
-- Arrange to evaluate the current expression
Push_Frame (Interp, Opcode_Evaluate_Object, Car);
when Mark_Object =>
Operand := Get_Frame_Result (Interp.Stack);
Pop_Frame (Interp); -- Done
-- 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_Result (Interp, Interp.Stack, Get_Car(Operand));
when others =>
raise Internal_Error;
end case;
Pop_Tops (Interp, 3);
end Evaluate_Group;
procedure Evaluate_Object is
pragma Inline (Evaluate_Object);
Operand: aliased Object_Pointer;
Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer;
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access);
Push_Top (Interp, Cdr'Unchecked_Access);
<<Start_Over>>
Operand := Get_Frame_Operand(Interp.Stack);
if not Is_Normal_Pointer(Operand) then
-- integer, character, specal pointers
-- TODO: some normal pointers may point to literal objects. e.g.) bignum
goto Literal;
end if;
case Operand.Tag is
when Symbol_Object => -- Is_Symbol(Operand)
-- TODO: find it in the Environment hierarchy.. not in the current environemnt.
Car := Get_Environment (Interp.Self, Operand);
if Car = null then
-- unbound
Ada.Text_IO.Put_Line ("Unbound symbol....");
Print (Interp, Operand);
raise Evaluation_Error;
else
-- symbol found in the environment
Operand := Car;
goto Literal; -- In fact, this is not a literal, but can be handled in the same way
end if;
when Cons_Object => -- Is_Cons(Operand)
Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand);
if Is_Syntax(Car) then
-- special syntax symbol. normal evaluate rule doesn't
-- apply for special syntax objects.
case Car.Scode is
when Begin_Syntax =>
Operand := Cdr; -- Skip "begin"
if not Is_Cons(Operand) then
-- e.g) (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);
Set_Frame_Operand (Interp.Stack, Operand);
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
-- I call Evaluate_Group for optimization here.
Evaluate_Group; -- for optimization only. not really needed.
-- I can jump to Start_Over because Evaluate_Group called
-- above pushes an Opcode_Evaluate_Object frame.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Evaluate_Object);
goto Start_Over; -- for optimization only. not really needed.
end if;
end if;
when Define_Syntax =>
-- (define x 10)
-- (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)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR DEFINE");
raise Syntax_Error;
elsif Get_Cdr(Operand) /= Nil_Pointer then
-- TODO: IMPLEMENT OTHER CHECK
null;
end if;
--Pop_Frame (Interp); -- Done
--Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand));
-- TODO: IMPLEMENT DEFINE.
when Lambda_Syntax =>
-- (lambda (x y) (+ x y));
Operand := Cdr; -- Skip "lambda"
if not Is_Cons(Operand) then
-- e.g) (lambda)
-- (lambda . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
raise Syntax_Error;
--Pop_Frame (Interp); -- Done
else
if not Is_Cons(Get_Car(Operand)) then
Ada.Text_IO.Put_Line ("INVALID PARRAMETER LIST");
raise Syntax_Error;
--Pop_Frame (Interp); -- Done
end if;
--Print (Interp, Get_Cdr(Operand));
if not Is_Cons(Get_Cdr(Operand)) then
Ada.Text_IO.Put_Line ("NO BODY");
raise Syntax_Error;
--Pop_Frame (Interp); -- Done
end if;
declare
Closure: Object_Pointer;
begin
Closure := Make_Closure (Interp.Self, Operand, Interp.Environment);
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Closure);
end;
end if;
when Quote_Syntax =>
Operand := Cdr; -- Skip "quote"
if not Is_Cons(Operand) then
-- e.g) (quote)
-- (quote . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR QUOTE");
raise Syntax_Error;
elsif Get_Cdr(Operand) /= Nil_Pointer then
Ada.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 =>
Ada.Text_IO.Put_Line ("Unknown syntax");
--Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- Switch to syntax evaluation
raise Internal_Error;
end case;
else
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
while not Is_Normal_Pointer(Car) loop
-- This while block is for optimization only. It's not really needed.
-- If I know that the next object to evaluate is a literal object,
-- I can simply reverse-chain it to the return field of the current
-- frame without pushing another frame dedicated for it.
-- TODO: some normal pointers may point to a literal object. e.g.) bignum
Chain_Frame_Result (Interp, Interp.Stack, Car);
if Is_Cons(Cdr) then
Operand := Cdr;
Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand);
else
-- last cons
Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack));
Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand);
goto Done;
end if;
end loop;
end if;
if Is_Cons(Cdr) then
-- Not the last cons cell yet
Set_Frame_Operand (Interp.Stack, Cdr); -- change the operand for the next call
else
-- Reached the last cons cell
if Cdr /= Nil_Pointer then
-- The last CDR is not Nil.
Ada.Text_IO.Put_Line ("$$$$..................FUCKING CDR.....................$$$$");
-- raise Syntax_Error;
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);
end if;
-- Arrange to evaluate the car object
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
Push_Frame (Interp, Opcode_Evaluate_Object, Car);
goto Start_Over; -- for optimization only. not really needed.
end if;
end if;
when Mark_Object =>
-- TODO: you can use the mark context to differentiate context
-- Get the evaluation result stored in the current stack frame by
-- various sub-Opcode_Evaluate_Object frames. the return value
-- chain must be reversed Chain_Frame_Result reverse-chains values.
Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack));
-- Refresh the current stack frame to Opcode_Apply.
-- This should be faster than Popping the current frame and pushing
-- a new frame.
-- Envir := Get_Frame_Environment(Interp.Stack);
-- Pop_Frame (Interp); -- done
-- Push_Frame (Interp, Opcode_Apply, Operand, Envir);
Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand);
when others =>
-- normal literal object
goto Literal;
end case;
goto Done;
<<Literal>>
Pop_Frame (Interp); -- done
Ada.Text_IO.Put ("Return => ");
Print (Interp, Operand);
Chain_Frame_Result (Interp, Interp.Stack, Operand);
goto Done;
<<Done>>
Pop_Tops (Interp, 3);
end Evaluate_Object;
procedure Evaluate_Procedure is
pragma Inline (Evaluate_Procedure);
begin
null;
end Evaluate_Procedure;
procedure Apply is
pragma Inline (Apply);
Operand: aliased Object_Pointer;
Func: aliased Object_Pointer;
Args: aliased Object_Pointer;
procedure Apply_Car_Procedure is
begin
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Args));
end Apply_Car_Procedure;
procedure Apply_Cdr_Procedure is
begin
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Get_Cdr(Args));
end Apply_Cdr_Procedure;
procedure Apply_Add_Procedure is
Ptr: Object_Pointer := Args;
Num: Object_Integer := 0; -- TODO: support BIGNUM
Car: Object_Pointer;
begin
while Ptr /= Nil_Pointer loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
raise Evaluation_Error;
end if;
Num := Num + Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
end loop;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Add_Procedure;
procedure Apply_Subtract_Procedure is
Ptr: Object_Pointer := Args;
Num: Object_Integer := 0; -- TODO: support BIGNUM
Car: Object_Pointer;
begin
if Ptr /= Nil_Pointer then
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
raise Evaluation_Error;
end if;
Num := Pointer_To_Integer(Car);
while Ptr /= Nil_Pointer loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
raise Evaluation_Error;
end if;
Num := Num - Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
end loop;
end if;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Subtract_Procedure;
procedure Apply_Closure is
Fbody: aliased Object_Pointer;
Param: aliased Object_Pointer;
Arg: aliased Object_Pointer;
begin
Push_Top (Interp, Fbody'Unchecked_Access);
Push_Top (Interp, Param'Unchecked_Access);
Push_Top (Interp, Arg'Unchecked_Access);
-- For a closure created of "(lambda (x y) (+ x y) (* x y))"
-- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))"
-- Push a new environmen for the closure
Interp.Environment := Make_Environment (Interp.Self, Get_Closure_Environment(Func));
Fbody := Get_Closure_Code(Func);
pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this.
Param := Get_Car(Fbody); -- Parameter list
--Arg := Get_Car(Args); -- Actual argument list
Arg := Args; -- Actual argument list
Fbody := Get_Cdr (Fbody); -- Real function body
pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this as wel..
while Is_Cons(Param) loop
if not Is_Cons(Arg) then
Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<");
raise Evaluation_Error;
end if;
-- Insert the key/value pair into the environment
Set_Environment (Interp, Get_Car(Param), Get_Car(Arg));
Param := Get_Cdr(Param);
Arg := Get_Cdr(Arg);
end loop;
-- Perform cosmetic checks for the parameter list
if Param /= Nil_Pointer then
Ada.Text_IO.Put_Line (">>> GARBAGE IN PARAMETER LIST <<<");
raise Syntax_Error;
end if;
-- Perform cosmetic checks for the argument list
if Is_Cons(Arg) then
Ada.Text_IO.Put_Line (">>>> Two many arguments <<<<");
raise Evaluation_Error;
elsif Arg /= Nil_Pointer then
Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<");
raise Syntax_Error;
end if;
-- TODO: is it correct to keep the environement in the frame?
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Operand (Interp.Stack, Fbody);
Clear_Frame_Result (Interp.Stack);
Pop_Tops (Interp, 3);
end Apply_Closure;
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Func'Unchecked_Access);
Push_Top (Interp, Args'Unchecked_Access);
Operand := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(Operand));
Print (Interp, Operand);
Func := Get_Car(Operand);
if not Is_Normal_Pointer(Func) then
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");
raise Evaluation_Error;
end if;
Args := Get_Cdr(Operand);
case Func.Tag is
when Procedure_Object =>
case Get_Procedure_Opcode(Func) is
when Car_Procedure =>
Apply_Car_Procedure;
when Cdr_Procedure =>
Apply_Cdr_Procedure;
when Add_Procedure =>
Apply_Add_Procedure;
when Subtract_Procedure =>
Apply_Subtract_Procedure;
when others =>
raise Internal_Error;
end case;
when Closure_Object =>
Apply_Closure;
when Continuation_Object =>
null;
when others =>
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");
raise Internal_Error;
end case;
Pop_Tops (Interp, 3);
end Apply;
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 = Ch.Space or else X = Ch.HT or else X = Ch.VT or else
X = Ch.CR or else X = Ch.LF or else X = Ch.FF;
end Is_White_Space;
function Is_Identifier_Stopper (X: in Object_Character) return Standard.Boolean is
begin
return X = Ch.Left_Parenthesis or else X = Ch.Right_Parenthesis or else
X = Ch.Apostrophe or else LC.Value = Ch.Quotation or else
X = Ch.Number_Sign or else LC.Value = Ch.Semicolon or else
Is_White_Space(X);
end Is_Identifier_Stopper;
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 = Ch.Semicolon then
-- Comment.
loop
Fetch_Character;
exit when LC.Kind = End_Character; -- EOF before LF
if LC.Kind = Normal_Character and then LC.Value = Ch.LF then -- TODO: handle different line ending convention
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
Tmp: Object_Character_Array(1..10); -- large enough???
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
-- Use Ch.Pos.XXX values instead of Ch.XXX values as gnat complained that
-- Ch.XXX values are not static. For this reason, "case LC.Value is ..."
-- changed to use Object_Character'Pos(LC.Value).
case Object_Character'Pos(LC.Value) is
when Ch.Pos.Left_Parenthesis =>
Token.Set (Interp, Left_Parenthesis_Token, LC.Value);
when Ch.Pos.Right_Parenthesis =>
Token.Set (Interp, Right_Parenthesis_Token, LC.Value);
when Ch.Pos.Period =>
Token.Set (Interp, Period_Token, LC.Value);
when Ch.Pos.Apostrophe =>
Token.Set (Interp, Single_Quote_Token, LC.Value);
when Ch.Pos.Quotation =>
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 = Ch.Backslash 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 = Ch.Quotation then
exit;
else
Token.Append_Character (Interp, LC.Value);
Fetch_Character;
end if;
end loop;
when Ch.Pos.Number_Sign =>
Fetch_Character;
-- TODO: t, false, etc
when Ch.Pos.Zero .. Ch.Pos.Nine =>
-- 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
LC.Value not in Ch.Zero .. Ch.Nine then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
exit;
end if;
end loop;
when Ch.Pos.Plus_Sign | Ch.Pos.Minus_Sign =>
Tmp(1) := LC.Value;
Fetch_Character;
if LC.Kind = Normal_Character and then
LC.Value in Ch.Zero .. Ch.Nine 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
LC.Value not in Ch.Zero .. Ch.Nine 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
Is_Identifier_Stopper(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 =>
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.Kind /= Normal_Character or else
Is_Identifier_Stopper(LC.Value) then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
exit;
end if;
end loop;
end case;
--Ada.Text_IO.Put (">>>>>>>>>>>>>>>>>>>>>>> Token: " & Interp.Token.Value.Ptr(1..Interp.Token.Value.Last));
end Fetch_Token;
procedure Read_List is
pragma Inline (Read_List);
V: aliased Object_Pointer;
begin
-- This procedure reads each token in a list.
-- If the list contains no period, this procedure reads up to the
-- closing right paranthesis; If a period is contained, it transfers
-- the control over to Read_List_Cdr.
Fetch_Token;
--Push_Top (Interp, V'Unchecked_Access);
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_Result(Interp.Stack);
if V /= Nil_Pointer then
V := Reverse_Cons(V);
end if;
Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, V);
when Period_Token =>
V := Get_Frame_Result(Interp.Stack);
if V = Nil_Pointer then
-- . immediately after (
raise Syntax_Error;
else
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_Cdr);
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 =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Result (Interp, Interp.Stack, V);
when others =>
-- TODO: set various error info
raise Syntax_Error;
end case;
--Pop_Tops (Interp, 1);
end Read_List;
procedure Read_List_Cdr is
pragma Inline (Read_List_Cdr);
V: aliased Object_Pointer;
begin
-- 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
-- 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 handle the head item specially.
Fetch_Token;
--Push_Top (Interp, V'Unchecked_Access);
case Interp.Token.Kind is
when End_Token =>
Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
raise Syntax_Error;
when Left_Parenthesis_Token =>
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
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 =>
V := Make_String (Interp.Self, 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 Identifier_Token =>
V := Make_Symbol (Interp.Self, 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 others =>
-- TODO: set various error info
raise Syntax_Error;
end case;
--Pop_Tops (Interp, 1);
end Read_List_Cdr;
procedure Read_List_End is
pragma Inline (Read_List_End);
V: aliased Object_Pointer;
begin
Fetch_Token;
--Push_Top (Interp, V'Unchecked_Access);
case Interp.Token.Kind is
when Right_Parenthesis_Token =>
V := Get_Frame_Result(Interp.Stack);
pragma Assert (V /= Nil_Pointer);
-- The first item in the chain is actually Cdr of the last cell.
V := Reverse_Cons(Get_Cdr(V), Get_Car(V));
Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, V);
when others =>
raise Syntax_Error;
end case;
--Pop_Tops (Interp, 1);
end Read_List_End;
procedure Close_List is
pragma Inline (Close_List);
V: aliased Object_Pointer;
begin
--Push_Top (Interp, V'Unchecked_Access);
V := Get_Frame_Result(Interp.Stack);
pragma Assert (Get_Cdr(V) = Nil_Pointer);
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Get_Car(V));
--Pop_Tops (Interp, 1);
end Close_List;
procedure Close_Quote is
pragma Inline (Close_Quote);
V: aliased Object_Pointer;
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));
V := Get_Frame_Result(Interp.Stack);
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
--Pop_Tops (Interp, 1);
end Close_Quote;
procedure Read_Object is
pragma Inline (Read_Object);
V: aliased Object_Pointer;
begin
Fetch_Token;
--Push_Top (Interp, V'Unchecked_Access);
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 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 =>
V := Make_String (Interp.Self, 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 Identifier_Token =>
V := Make_Symbol (Interp.Self, 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 others =>
-- TODO: set various error info
raise Syntax_Error;
end case;
--Pop_Tops (Interp, 1);
end Read_Object;
begin
-- Stack frames looks like this upon initialization
--
-- | Opcode | Operand | Result
-- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | Source | Nil
-- bottom | Opcode_Exit | Nil | Nil
--
-- For a source (+ 1 2), it should look like this.
-- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | Source | Nil
-- bottom | Opcode_Exit | Nil | Nil
--
-- The operand changes to the cdr of the source.
-- The symbol '+' is pushed to the stack with Opcode_Evaluate_Object.
-- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | + | Nil
-- | Opcode_Evaluate_Object | (1 2) | Nil
-- bottom | Opcode_Exit | Nil | Nil
--
-- After the evaluation of the symbol, the pushed frame is removed
-- and the result is set to the return field.
-- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | (1 2) | (#Proc+)
-- bottom | Opcode_Exit | Nil | Nil
--
-- The same action is taken to evaluate the literal 1.
-- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | 1 | Nil
-- | Opcode_Evaluate_Object | (2) | (#Proc+)
-- bottom | Opcode_Exit | Nil | Nil
--
-- The result of the valuation is reverse-chained to the return field.
-- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | (2) | (1 #Proc+)
-- bottom | Opcode_Exit | Nil | Nil
--
-- The same action is taken to evaluate the literal 2.
-- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | 2 | Nil
-- | Opcode_Evaluate_Object | Mark | (1 #Proc+)
-- bottom | Opcode_Exit | Nil | Nil
--
-- The result of the valuation is reverse-chained to the return field.
-- -----------------------------------------------------------------
-- top | Opcode_Evaluate_Object | Mark | (2 1 #Proc+)
-- bottom | Opcode_Exit | Nil | Nil
--
-- Once evluation of each cons cell is complete, switch the top frame
-- to 'Apply' reversing the result field into the operand field and
-- nullifying the result field afterwards.
-- -----------------------------------------------------------------
-- top | Apply | (#Proc+ 1 2) | Nil
-- bottom | Opcode_Exit | Nil | Nil
--
-- The apply operation produces the final result and sets it to the
-- parent frame while removing the apply frame.
-- -----------------------------------------------------------------
-- top/bottom| Opcode_Exit | Nil | (3)
-- The caller must push some frames before calling this procedure
pragma Assert (Interp.Stack /= Nil_Pointer);
-- The caller must ensure there are no temporary object pointers.
pragma Assert (Interp.Top.Last < Interp.Top.Data'First);
loop
case Get_Frame_Opcode(Interp.Stack) is
when Opcode_Exit =>
exit;
when Opcode_Evaluate_Result =>
Evaluate_Result;
when Opcode_Evaluate_Object =>
Evaluate_Object;
when Opcode_Evaluate_Group =>
Evaluate_Group;
when Opcode_Evaluate_Procedure =>
Evaluate_Procedure;
when Opcode_Apply =>
Apply;
when Opcode_Read_Object =>
Read_Object;
when Opcode_Read_List =>
Read_List;
when Opcode_Read_List_Cdr =>
Read_List_Cdr;
when Opcode_Read_List_End =>
Read_List_End;
when Opcode_Close_List =>
Close_List;
when Opcode_Close_Quote =>
Close_Quote;
end case;
end loop;
exception
when Stream_End_Error =>
raise;
when others =>
Ada.Text_IO.Put_Line ("EXCEPTION OCCURRED");
-- TODO: restore stack frame???
-- TODO: restore envirronemtn frame???
raise;
end Execute;
Reference in New Issue View Git Blame Copy Permalink