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

addded a new slot to hold an intermediate value to a frame object.

Browse Source 
made partial changes relevant
This commit is contained in:
hyung-hwan 2014-02-05 15:08:59 +00:00
parent 76d46b4964
commit 032dda2263
4 changed files with 188 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -448,12 +448,13 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Cdr := Get_Car(Cdr); -- <expression>
-- Arrange to finish setting a variable after <expression> evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Set_Finish);
Set_Frame_Operand (Interp.Stack, Car);
Clear_Frame_Result (Interp.Stack);
--Switch_Frame (Interp.Stack, Opcode_Set_Finish, Car);
-- Arrange to evalaute the value part
Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
--Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
-- These 2 lines derives the same result as the 2 lines commented out above.
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr);
Push_Subframe (Interp, Opcode_Set_Finish, Car);
else
Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!");
raise Syntax_Error;
@ -526,9 +527,7 @@ end;
raise Syntax_Error;
end if;
Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call);
Set_Frame_Operand (Interp.Stack, Operand);
Clear_Frame_Result (Interp.Stack);
Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Operand);
end if;
--if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
@ -580,17 +579,11 @@ end;
raise Syntax_Error;
end if;
-- Create a cons cell whose 'car' holds arguments and
-- 'cdr' holds evaluation results before applying them.
Cdr := Make_Cons (Interp.Self, Cdr, Nil_Pointer);
-- Switch the current frame to evaluate <operator>
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car);
-- Set it as a frame operand
Set_Frame_Opcode (Interp.Stack, Opcode_Procedure_Call);
Set_Frame_Operand (Interp.Stack, Cdr);
Clear_Frame_Result (Interp.Stack);
-- Arrange to evaluate <operator> first.
Push_Frame (Interp, Opcode_Evaluate_Object, Car);
-- Push a new frame to evaluate arguments.
Push_Subframe (Interp, Opcode_Procedure_Call, Cdr);
end if;
when others =>

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

@ -14,7 +14,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- 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)));
Set_Frame_Operand (Interp.Stack, Get_Frame_Result(Interp.Stack));
Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object);
end Evaluate_Result;
@ -32,11 +32,8 @@ procedure Execute (Interp: in out Interpreter_Record) is
Y := Get_Frame_Result(Interp.Stack);
-- Evaluate_And_Syntax/Evaluate_Or_Syntax has arranged to
-- evaluate <test1>. Y must not be Nil_Pointer even at the
-- first time this procedure is called,
pragma Assert (Is_Cons(Y));
pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure 1 resul
Y := Get_Car(Y); -- actual result
-- evaluate <test1>. Y must be valid even at the first time
-- this procedure is called.
if Y /= V and then Is_Cons(X) then
-- The result is not what I look for.
@ -67,8 +64,6 @@ procedure Execute (Interp: in out Interpreter_Record) is
pragma Assert (Is_Symbol(X));
Y := Get_Frame_Result(Interp.Stack); -- value list
pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure only 1 return value
Y := Get_Car(Y); -- the first value
Put_Environment (Interp, X, Y);
@ -91,8 +86,6 @@ procedure Execute (Interp: in out Interpreter_Record) is
pragma Assert (Is_Cons(X));
Y := Get_Frame_Result(Interp.Stack); -- result list of <test>
pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure only 1 return value
Y := Get_Car(Y); -- the first value
if Y = False_Pointer then
-- <test> evaluated to #f.
@ -125,95 +118,47 @@ procedure Execute (Interp: in out Interpreter_Record) is
procedure Do_Procedure_Call is
pragma Inline (Do_Procedure_Call);
X: aliased Object_Pointer;
S: aliased Object_Pointer;
R: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, S'Unchecked_Access);
Push_Top (Interp, R'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(X));
R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Get_Frame_Intermediate(Interp.Stack));
-- When this procedure is called for the first time,
-- the first argument must be at the head of the list that
-- 'S' points to. it's because <operator> evaluation frame
-- is pushed by Evaluate().
S := Get_Car(X);
R := Get_Cdr(X);
-- Threfore, the frame result is for <operator> for the first call.
R := Make_Cons(Interp.Self, Get_Car(Get_Frame_Result(Interp.Stack)), R);
Clear_Frame_Result (Interp.Stack);
if Is_Cons(S) then
Set_Cdr (X, R); -- chain the result
Set_Car (X, Get_Cdr(S)); -- remember the next <operator> to evaluate
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(S));
if Is_Cons(X) then
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X));
Push_Subframe_With_Intermediate (Interp, Opcode_Procedure_Call, Get_Cdr(X), R);
else
-- no more argument to evaluate.
-- apply the evaluated arguments to the evaluated operator.
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Reverse_Cons(R));
Switch_Frame (Interp.Stack, Opcode_Apply, Reverse_Cons(R));
end if;
Pop_Tops (Interp, 3);
Pop_Tops (Interp, 2);
end Do_Procedure_Call;
-- ----------------------------------------------------------------
procedure Do_Grouped_Call is
pragma Inline (Do_Grouped_Call);
X: Object_Pointer;
begin
X := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(X)); -- The caller must ensure this.
--if Is_Cons(X) then
Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call_Finish);
Set_Frame_Operand (Interp.Stack, Get_Cdr(X));
Clear_Frame_Result (Interp.Stack);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
--else
-- -- Nothing to evaluate.
-- Pop_Frame (Interp);
-- Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer);
--end if;
end Do_Grouped_Call;
procedure Do_Grouped_Call_Finish is
X: Object_Pointer;
R: Object_Pointer;
begin
X := Get_Frame_Operand(Interp.Stack);
-- Switch the current frame to evaluate the first
-- expression in the group.
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X));
X := Get_Cdr(X);
if Is_Cons(X) then
Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call_Finish);
Set_Frame_Operand (Interp.Stack, Get_Cdr(X));
Clear_Frame_Result (Interp.Stack);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
else
-- Nothing more to evaluate.
R := Get_Frame_Result(Interp.Stack);
declare
w: object_word;
for w'address use interp.stack'address;
begin
ada.text_io.put_line ("Frame" & object_word'image(w) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
ada.text_io.put (" EVAL-GROUP RESULT ");
print (Interp, R);
end;
-- There must be only 1 return value chained in the Group frame.
pragma Assert (Get_Cdr(R) = Nil_Pointer);
Pop_Frame (Interp);
-- Return the last result to the upper frame
Put_Frame_Result (Interp, Interp.Stack, Get_Car(R));
-- Add a new frame for handling the remaining expressions in
-- the group. Place it below the current frame so that it's
-- executed after the current frame switched is executed first.
Push_Subframe (Interp, Opcode_Grouped_Call, X);
end if;
end Do_Grouped_Call_Finish;
end Do_Grouped_Call;
-- ----------------------------------------------------------------
@ -238,7 +183,7 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
-- Subsequent calls. Store the result in the room created
-- in the previous call.
pragma Assert (Is_Cons(R));
Set_Car (R, Get_Car(Get_Frame_Result(Interp.Stack)));
Set_Car (R, Get_Frame_Result(Interp.Stack));
end if;
S := X.Pointer_Slot(2);
@ -322,22 +267,19 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
procedure Do_Letast_Binding_Finish is
pragma Inline (Do_Letast_Binding_Finish);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
Envir: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
Push_Top (Interp, Envir'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
Y := Get_Frame_Result(Interp.Stack);
-- Update the environment while evaluating <bindings>
-- Push a new environment for each binding.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir);
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack));
X := Get_Cdr(X); -- next binding
if Is_Cons(X) then
@ -357,7 +299,7 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
Set_Frame_Environment (Interp.Stack, Envir);
end if;
Pop_Tops (Interp, 3);
Pop_Tops (Interp, 2);
end Do_Letast_Binding_Finish;
procedure Do_Let_Finish is
@ -381,14 +323,13 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- symbol
Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- value
Y := Get_Frame_Result(Interp.Stack); -- value
ada.text_io.put ("%%%%% FINISH SET SYNTAX => ");
print (interp, Get_Frame_Result(Interp.Stack));
pragma Assert (Is_Symbol(X));
pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
if Set_Environment(Interp.Self, X, Y) = null then
Ada.Text_IO.PUt_LINE ("ERROR: UNBOUND SYMBOL");
Ada.Text_IO.Put_LINE ("ERROR: UNBOUND SYMBOL");
raise Evaluation_Error;
end if;
@ -693,7 +634,7 @@ print (interp, Get_Frame_Result(Interp.Stack));
procedure Read_List is
pragma Inline (Read_List);
V: aliased Object_Pointer;
V: Object_Pointer;
begin
-- This procedure reads each token in a list.
-- If the list contains no period, this procedure reads up to the
@ -702,8 +643,6 @@ print (interp, Get_Frame_Result(Interp.Stack));
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");
@ -713,15 +652,15 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
Push_Frame (Interp, Opcode_Read_List, Nil_Pointer);
when Right_Parenthesis_Token =>
V := Get_Frame_Result(Interp.Stack);
if V /= Nil_Pointer then
V := Get_Frame_Intermediate(Interp.Stack);
if Is_Cons(V) then
V := Reverse_Cons(V);
end if;
Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, V);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when Period_Token =>
V := Get_Frame_Result(Interp.Stack);
V := Get_Frame_Intermediate(Interp.Stack);
if V = Nil_Pointer then
-- . immediately after (
raise Syntax_Error;
@ -736,38 +675,37 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
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);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Chain_Frame_Result (Interp, Interp.Stack, V);
Chain_Frame_Intermediate (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);
Chain_Frame_Intermediate (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);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when True_Token =>
Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
Chain_Frame_Intermediate (Interp, Interp.Stack, True_Pointer);
when False_Token =>
Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
Chain_Frame_Intermediate (Interp, Interp.Stack, False_Pointer);
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;
V: 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
@ -776,8 +714,6 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE 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");
@ -797,100 +733,86 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
-- 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);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, V);
Chain_Frame_Intermediate (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);
Chain_Frame_Intermediate (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);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when True_Token =>
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
Chain_Frame_Intermediate (Interp, Interp.Stack, True_Pointer);
when False_Token =>
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
Chain_Frame_Intermediate (Interp, Interp.Stack, False_Pointer);
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;
V: 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);
V := Get_Frame_Intermediate(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);
Set_Frame_Result (Interp.Stack, V);
when others =>
Ada.Text_IO.Put_Line ("Right parenthesis expected");
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;
V: 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);
V := Get_Frame_Intermediate(Interp.Stack);
Pop_Frame (Interp);
Set_Frame_Result (Interp.Stack, Get_Car(V));
end Close_List;
procedure Close_Quote is
pragma Inline (Close_Quote);
V: aliased Object_Pointer;
V: Object_Pointer;
begin
--Push_Top (Interp, V'Unchecked_Access);
Chain_Frame_Result (Interp, Interp.Stack, Interp.Symbol.Quote);
V := Get_Frame_Result(Interp.Stack);
V := Make_Cons(Interp.Self, V, Nil_Pointer);
V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V);
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
--Pop_Tops (Interp, 1);
Set_Frame_Result (Interp.Stack, V);
end Close_Quote;
procedure Read_Object is
pragma Inline (Read_Object);
V: aliased Object_Pointer;
V: 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 ");
@ -908,32 +830,31 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE 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);
Set_Frame_Result (Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
Set_Frame_Result (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);
Set_Frame_Result (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);
Set_Frame_Result (Interp.Stack, V);
when True_Token =>
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
Set_Frame_Result (Interp.Stack, True_Pointer);
when False_Token =>
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
Set_Frame_Result (Interp.Stack, False_Pointer);
when others =>
-- TODO: set various error info
@ -941,7 +862,6 @@ Ada.Text_IO.Put_Line ("INFO: UNKNOWN TOKEN " & Token_Kind'Image(Interp.Token.Kin
raise Syntax_Error;
end case;
--Pop_Tops (Interp, 1);
end Read_Object;
begin
@ -1012,6 +932,7 @@ begin
pragma Assert (Interp.Top.Last < Interp.Top.Data'First);
loop
ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
case Get_Frame_Opcode(Interp.Stack) is
when Opcode_Exit =>
exit;
@ -1036,8 +957,6 @@ begin
when Opcode_Grouped_Call =>
Do_Grouped_Call;
when Opcode_Grouped_Call_Finish =>
Do_Grouped_Call_Finish;
when Opcode_Let_Binding =>
Do_Let_Binding;

169
lib/h2-scheme.adb
View File

@ -103,7 +103,6 @@ package body H2.Scheme is
Opcode_Finish_Or_Syntax,
Opcode_Grouped_Call, -- (begin ...), closure apply, let body
Opcode_Grouped_Call_Finish,
Opcode_Let_Binding,
Opcode_Letast_Binding,
Opcode_Letast_Binding_Finish,
@ -130,12 +129,13 @@ package body H2.Scheme is
Cons_Car_Index: constant Pointer_Object_Size := 1;
Cons_Cdr_Index: constant Pointer_Object_Size := 2;
Frame_Object_Size: constant Pointer_Object_Size := 5;
Frame_Object_Size: constant Pointer_Object_Size := 6;
Frame_Parent_Index: constant Pointer_Object_Size := 1;
Frame_Opcode_Index: constant Pointer_Object_Size := 2;
Frame_Operand_Index: constant Pointer_Object_Size := 3;
Frame_Environment_Index: constant Pointer_Object_Size := 4;
Frame_Result_Index: constant Pointer_Object_Size := 5;
Frame_Intermediate_Index: constant Pointer_Object_Size := 5;
Frame_Result_Index: constant Pointer_Object_Size := 6;
Procedure_Object_Size: constant Pointer_Object_Size := 1;
Procedure_Opcode_Index: constant Pointer_Object_Size := 1;
@ -1145,12 +1145,14 @@ Ada.Text_IO.Put_Line ("Make_String...");
Stack: in Object_Pointer; -- current stack pointer
Opcode: in Object_Pointer;
Operand: in Object_Pointer;
Envir: in Object_Pointer) return Object_Pointer is
Envir: in Object_Pointer;
Interm: in Object_Pointer) return Object_Pointer is
Frame: Object_Pointer;
Aliased_Stack: aliased Object_Pointer := Stack;
Aliased_Opcode: aliased Object_Pointer := Opcode;
Aliased_Operand: aliased Object_Pointer := Operand;
Aliased_Envir: aliased Object_Pointer := Envir;
Aliased_Interm: aliased Object_Pointer := Interm;
begin
@ -1158,6 +1160,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Push_Top (Interp.all, Aliased_Opcode'Unchecked_Access);
Push_Top (Interp.all, Aliased_Operand'Unchecked_Access);
Push_Top (Interp.all, Aliased_Envir'Unchecked_Access);
Push_Top (Interp.all, Aliased_Interm'Unchecked_Access);
-- TODO: create a Frame in a special memory rather than in Heap Memory.
-- Since it's used for stack, it can be made special.
@ -1167,9 +1170,10 @@ Ada.Text_IO.Put_Line ("Make_String...");
Frame.Pointer_Slot(Frame_Opcode_Index) := Aliased_Opcode;
Frame.Pointer_Slot(Frame_Operand_Index) := Aliased_Operand;
Frame.Pointer_Slot(Frame_Environment_Index) := Aliased_Envir;
Frame.Pointer_Slot(Frame_Intermediate_Index) := Aliased_Interm;
--Print_Object_Pointer ("Make_Frame Result - ", Result);
Pop_Tops (Interp.all, 4);
Pop_Tops (Interp.all, 5);
return Frame;
end Make_Frame;
@ -1180,6 +1184,50 @@ Ada.Text_IO.Put_Line ("Make_String...");
Source.Tag = Frame_Object;
end Is_Frame;
function Get_Frame_Intermediate (Frame: in Object_Pointer) return Object_Pointer is
pragma Inline (Get_Frame_Intermediate);
pragma Assert (Is_Frame(Frame));
begin
return Frame.Pointer_Slot(Frame_Intermediate_Index);
end Get_Frame_Intermediate;
procedure Set_Frame_Intermediate (Frame: in Object_Pointer;
Value: in Object_Pointer) is
pragma Inline (Set_Frame_Intermediate);
pragma Assert (Is_Frame(Frame));
-- This procedure is not to set a single result,
-- but to set the result chain. so it can be useful
-- if you want to migrate a result chain from one frame
-- to another. It's what this assertion is for.
pragma Assert (Value = Nil_Pointer or else Is_Cons(Value));
begin
Frame.Pointer_Slot(Frame_Intermediate_Index) := Value;
end Set_Frame_Intermediate;
procedure Chain_Frame_Intermediate (Interp: in out Interpreter_Record;
Frame: in Object_Pointer;
Value: in Object_Pointer) is
pragma Inline (Chain_Frame_Intermediate);
pragma Assert (Is_Frame(Frame));
V: Object_Pointer;
begin
-- Add a new cons cell to the front
--Push_Top (Interp, Frame'Unchecked_Access);
--Frame.Pointer_Slot(Frame_Intermediate_Index) :=
-- Make_Cons(Interp.Self, Value, Frame.Pointer_Slot(Frame_Intermediate_Index));
--Pop_Tops (Interp, 1);
-- This seems to cause a problem if Interp.Stack changes in Make_Cons().
--Interp.Stack.Pointer_Slot(Frame_Intermediate_Index) :=
-- Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Intermediate_Index));
-- So, let's separate the evaluation and the assignment.
V := Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Intermediate_Index));
Interp.Stack.Pointer_Slot(Frame_Intermediate_Index) := V;
end Chain_Frame_Intermediate;
function Get_Frame_Result (Frame: in Object_Pointer) return Object_Pointer is
pragma Inline (Get_Frame_Result);
pragma Assert (Is_Frame(Frame));
@ -1191,12 +1239,6 @@ Ada.Text_IO.Put_Line ("Make_String...");
Value: in Object_Pointer) is
pragma Inline (Set_Frame_Result);
pragma Assert (Is_Frame(Frame));
-- This procedure is not to set a single result,
-- but to set the result chain. so it can be useful
-- if you want to migrate a result chain from one frame
-- to another. It's what this assertion is for.
pragma Assert (Value = Nil_Pointer or else Is_Cons(Value));
begin
Frame.Pointer_Slot(Frame_Result_Index) := Value;
end Set_Frame_Result;
@ -1206,36 +1248,10 @@ Ada.Text_IO.Put_Line ("Make_String...");
Value: in Object_Pointer) is
pragma Inline (Put_Frame_Result);
pragma Assert (Is_Frame(Frame));
V: Object_Pointer;
begin
V := Make_Cons(Interp.Self, Value, Nil_Pointer);
Interp.Stack.Pointer_Slot(Frame_Result_Index) := V;
Interp.Stack.Pointer_Slot(Frame_Result_Index) := Value;
end Put_Frame_Result;
procedure Chain_Frame_Result (Interp: in out Interpreter_Record;
Frame: in Object_Pointer; -- TODO: remove this parameter
Value: in Object_Pointer) is
pragma Inline (Chain_Frame_Result);
pragma Assert (Is_Frame(Frame));
V: Object_Pointer;
begin
-- Add a new cons cell to the front
--Push_Top (Interp, Frame'Unchecked_Access);
--Frame.Pointer_Slot(Frame_Result_Index) :=
-- Make_Cons(Interp.Self, Value, Frame.Pointer_Slot(Frame_Result_Index));
--Pop_Tops (Interp, 1);
-- This seems to cause a problem if Interp.Stack changes in Make_Cons().
--Interp.Stack.Pointer_Slot(Frame_Result_Index) :=
-- Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index));
-- So, let's separate the evaluation and the assignment.
V := Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index));
Interp.Stack.Pointer_Slot(Frame_Result_Index) := V;
end Chain_Frame_Result;
procedure Clear_Frame_Result (Frame: in Object_Pointer) is
begin
Frame.Pointer_Slot(Frame_Result_Index) := Nil_Pointer;
@ -1286,7 +1302,6 @@ Ada.Text_IO.Put_Line ("Make_String...");
Frame.Pointer_Slot(Frame_Operand_Index) := Value;
end Set_Frame_Operand;
function Get_Frame_Parent (Frame: in Object_Pointer) return Object_Pointer is
pragma Inline (Get_Frame_Parent);
pragma Assert (Is_Frame(Frame));
@ -1294,6 +1309,15 @@ Ada.Text_IO.Put_Line ("Make_String...");
return Frame.Pointer_Slot(Frame_Parent_Index);
end Get_Frame_Parent;
procedure Switch_Frame (Frame: in Object_Pointer;
Opcode: in Opcode_Type;
Operand: in Object_Pointer) is
begin
Set_Frame_Opcode (Frame, Opcode);
Set_Frame_Operand (Frame, Operand);
Set_Frame_Result (Frame, Nil_Pointer);
--Set_Frame_Intermediate (Frame, Nil_Pointer);
end Switch_Frame;
-----------------------------------------------------------------------------
@ -1772,7 +1796,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Initialize_Heap (Initial_Heap_Size);
Interp.Root_Environment := Make_Environment(Interp.Self, Nil_Pointer);
Interp.Root_Frame := Make_Frame(Interp.Self, Nil_Pointer, Opcode_To_Pointer(Opcode_Exit), Nil_Pointer, Interp.Root_Environment);
Interp.Root_Frame := Make_Frame(Interp.Self, Nil_Pointer, Opcode_To_Pointer(Opcode_Exit), Nil_Pointer, Interp.Root_Environment, Nil_Pointer);
Interp.Stack := Interp.Root_Frame;
Make_Syntax_Objects;
@ -2006,7 +2030,7 @@ end if;
-- TODO: use a interp.Stack.
-- TODO: use Push_Frame
Stack := Make_Frame (Interp.Self, Nil_Pointer, Integer_To_Pointer(0), Nil_Pointer, Nil_Pointer); -- just for get_frame_environment...
Stack := Make_Frame (Interp.Self, Nil_Pointer, Integer_To_Pointer(0), Nil_Pointer, Nil_Pointer, Nil_Pointer); -- just for get_frame_environment...
Opcode := 1;
Operand := Source;
@ -2016,7 +2040,7 @@ end if;
when 1 =>
if Is_Cons(Operand) then
-- push cdr
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer); -- push cdr
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push cdr
Ada.Text_IO.Put ("(");
Operand := Get_Car(Operand);
Opcode := 1;
@ -2036,7 +2060,7 @@ end if;
if Is_Cons(Operand) then
-- push cdr
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer); -- push
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push
Ada.Text_IO.Put (" ");
Operand := Get_Car(Operand); -- car
Opcode := 1;
@ -2066,14 +2090,26 @@ end if;
Ada.Text_IO.New_Line;
end Print;
procedure Insert_Frame (Interp: in out Interpreter_Record;
Parent: in out Object_Pointer;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Envir: in Object_Pointer;
Interm: in Object_Pointer) is
pragma Inline (Insert_Frame);
pragma Assert (Parent = Nil_Pointer or else Is_Frame(Parent));
begin
Parent := Make_Frame(Interp.Self, Parent, Opcode_To_Pointer(Opcode), Operand, Envir, Interm);
end Insert_Frame;
procedure Push_Frame (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer) is
pragma Inline (Push_Frame);
begin
Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode),
Operand, Get_Frame_Environment(Interp.Stack));
--Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode),
-- Operand, Get_Frame_Environment(Interp.Stack));
Insert_Frame (Interp, Interp.Stack, Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer);
end Push_Frame;
procedure Push_Frame_With_Environment (Interp: in out Interpreter_Record;
@ -2082,10 +2118,43 @@ end if;
Envir: in Object_Pointer) is
pragma Inline (Push_Frame_With_Environment);
begin
Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode),
Operand, Envir);
--Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode),
-- Operand, Envir);
Insert_Frame (Interp, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer);
end Push_Frame_With_Environment;
procedure Push_Subframe (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer) is
pragma Inline (Push_Subframe);
begin
-- Place a new frame below the existing top frame.
Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index),
Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer);
end Push_Subframe;
procedure Push_Subframe_With_Environment (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Envir: in Object_Pointer) is
pragma Inline (Push_Subframe_With_Environment);
begin
-- Place a new frame below the existing top frame.
Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index),
Opcode, Operand, Envir, Nil_Pointer);
end Push_Subframe_With_Environment;
procedure Push_Subframe_With_Intermediate (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Interm: in Object_Pointer) is
pragma Inline (Push_Subframe_With_Intermediate);
begin
-- Place a new frame below the existing top frame.
Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index),
Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm);
end Push_Subframe_With_Intermediate;
procedure Pop_Frame (Interp: in out Interpreter_Record) is
pragma Inline (Pop_Frame);
begin
@ -2117,10 +2186,6 @@ end if;
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);
Result := Get_Frame_Result(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);
Result := Get_Car(Result); -- Get the only value chained
Clear_Frame_Result (Interp.Stack);
end Evaluate;
@ -2154,8 +2219,6 @@ end if;
-- TODO: this result must be kept at some where that GC dowsn't sweep.
Result := Get_Frame_Result(Interp.Stack);
pragma Assert (Get_Cdr(Result) = Nil_Pointer);
Result := Get_Car(Result);
Clear_Frame_Result (Interp.Stack);
Ada.Text_IO.Put ("RESULT>>>>>");

1
lib/h2-scheme.ads
View File

@ -500,7 +500,6 @@ private
Root_Environment: Object_Pointer := Nil_Pointer;
Root_Frame: Object_Pointer := Nil_Pointer;
Stack: Object_Pointer := Nil_Pointer;
Active_Frame: Object_Pointer := NIl_Pointer;
Symbol: Common_Symbol_Record;
Top: Top_Record; -- temporary object pointers