added some code to evaluate
This commit is contained in:
parent
0f96ff8851
commit
d2b6a11da6
@ -8,12 +8,18 @@ procedure scheme is
|
||||
Pool: aliased Storage.Global_Pool;
|
||||
SI: S.Interpreter_Record;
|
||||
|
||||
I: S.Object_Pointer;
|
||||
O: S.Object_Pointer;
|
||||
begin
|
||||
Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Pointer_Bytes));
|
||||
|
||||
S.Open (SI, 2_000_000, Pool'Unchecked_Access);
|
||||
--S.Open (SI, null);
|
||||
S.Evaluate (SI);
|
||||
S.Make_Test_Object (SI, I);
|
||||
S.Evaluate (SI, I, O);
|
||||
S.Print (SI, I);
|
||||
Ada.Text_IO.Put_Line ("-------------------------------------------");
|
||||
S.Print (SI, O);
|
||||
S.Close (SI);
|
||||
|
||||
declare
|
||||
|
||||
@ -20,6 +20,14 @@ package body H2.Scheme is
|
||||
type Thin_Memory_Element_Array_Pointer is access all Thin_Memory_Element_Array;
|
||||
for Thin_Memory_Element_Array_Pointer'Size use Object_Pointer_Bits;
|
||||
|
||||
subtype Opcode_Type is Object_Integer range 0 .. 5;
|
||||
Opcode_Exit: constant Opcode_Type := Opcode_Type'(0);
|
||||
Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(1);
|
||||
Opcode_Evaluate_Argument: constant Opcode_Type := Opcode_Type'(2);
|
||||
Opcode_Evaluate_Syntax: constant Opcode_Type := Opcode_Type'(3);
|
||||
Opcode_Evaluate_Procedure: constant Opcode_Type := Opcode_Type'(4);
|
||||
Opcode_Apply: constant Opcode_Type := Opcode_Type'(5);
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
-- COMMON OBJECTS
|
||||
----------------------------------------------------------------------------------
|
||||
@ -27,10 +35,19 @@ 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 := 3;
|
||||
Frame_Object_Size: constant Pointer_Object_Size := 5;
|
||||
Frame_Stack_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_Return_Index: constant Pointer_Object_Size := 5;
|
||||
|
||||
Procedure_Object_Size: constant Pointer_Object_Size := 1;
|
||||
Procedure_Opcode_Index: constant Pointer_Object_Size := 1;
|
||||
|
||||
Closure_Object_Size: constant Pointer_Object_Size := 2;
|
||||
Closure_Code_Index: constant Pointer_Object_Size := 1;
|
||||
Closure_Environment_Index: constant Pointer_Object_Size := 2;
|
||||
|
||||
procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Memory_Element_Pointer);
|
||||
procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Object_Pointer);
|
||||
@ -293,8 +310,15 @@ package body H2.Scheme is
|
||||
procedure Print_Object_Pointer (Msg: in Object_String; Source: in Object_Pointer) is
|
||||
W: Object_Word;
|
||||
for W'Address use Source'Address;
|
||||
|
||||
Ptr_Type: Object_Pointer_Type;
|
||||
begin
|
||||
if Is_Special_Pointer (Source) then
|
||||
Ptr_Type := Get_Pointer_Type(Source);
|
||||
if Ptr_Type = Object_Pointer_Type_Character then
|
||||
Text_IO.Put_Line (Msg & Object_Character'Image(Pointer_To_Character(Source)));
|
||||
elsif Ptr_Type = Object_Pointer_Type_Integer then
|
||||
Text_IO.Put_Line (Msg & Object_Integer'Image(Pointer_To_Integer(Source)));
|
||||
elsif Is_Special_Pointer (Source) then
|
||||
Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W));
|
||||
elsif Source.Kind = Character_Object then
|
||||
Text_IO.Put (Msg & " at " & Object_Word'Image(W) & " at " & Object_Kind'Image(Source.Kind) & " size " & Object_Size'Image(Source.Size) & " - ");
|
||||
@ -748,6 +772,40 @@ Text_IO.Put_Line (">>> [GC DONE]");
|
||||
Source.Tag = Cons_Object;
|
||||
end Is_Cons;
|
||||
|
||||
function Get_Car (Source: in Object_Pointer) return Object_Pointer is
|
||||
pragma Inline (Get_Car);
|
||||
begin
|
||||
pragma Assert (Is_Cons (Source));
|
||||
pragma Assert (Source.Size = Cons_Object_Size);
|
||||
return Source.Pointer_Slot(Cons_Car_Index);
|
||||
end Get_Car;
|
||||
|
||||
procedure Set_Car (Source: in out Object_Pointer;
|
||||
Value: in Object_Pointer) is
|
||||
pragma Inline (Set_Car);
|
||||
begin
|
||||
pragma Assert (Is_Cons (Source));
|
||||
pragma Assert (Source.Size = Cons_Object_Size);
|
||||
Source.Pointer_Slot(Cons_Car_Index) := Value;
|
||||
end Set_Car;
|
||||
|
||||
function Get_Cdr (Source: in Object_Pointer) return Object_Pointer is
|
||||
pragma Inline (Get_Cdr);
|
||||
begin
|
||||
pragma Assert (Is_Cons (Source));
|
||||
pragma Assert (Source.Size = Cons_Object_Size);
|
||||
return Source.Pointer_Slot(Cons_Cdr_Index);
|
||||
end Get_Cdr;
|
||||
|
||||
procedure Set_Cdr (Source: in out Object_Pointer;
|
||||
Value: in Object_Pointer) is
|
||||
pragma Inline (Set_Cdr);
|
||||
begin
|
||||
pragma Assert (Is_Cons (Source));
|
||||
pragma Assert (Source.Size = Cons_Object_Size);
|
||||
Source.Pointer_Slot(Cons_Cdr_Index) := Value;
|
||||
end Set_Cdr;
|
||||
|
||||
procedure Make_Cons (Interp: in out Interpreter_Record;
|
||||
Car: in Object_Pointer;
|
||||
Cdr: in Object_Pointer;
|
||||
@ -760,6 +818,17 @@ Text_IO.Put_Line (">>> [GC DONE]");
|
||||
Print_Object_Pointer ("Make_Cons Result - ", Result);
|
||||
end Make_Cons;
|
||||
|
||||
function Make_Cons (Interp: access Interpreter_Record;
|
||||
Car: in Object_Pointer;
|
||||
Cdr: in Object_Pointer) return Object_Pointer is
|
||||
Result: Object_Pointer;
|
||||
begin
|
||||
Make_Cons (Interp.all, Car, Cdr, Result);
|
||||
return Result;
|
||||
end Make_Cons;
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
procedure Make_String (Interp: in out Interpreter_Record;
|
||||
Source: in Object_String;
|
||||
Result: out Object_Pointer) is
|
||||
@ -769,6 +838,13 @@ Print_Object_Pointer ("Make_Cons Result - ", Result);
|
||||
Print_Object_Pointer ("Make_String Result - " & Source, Result);
|
||||
end Make_String;
|
||||
|
||||
function Is_Symbol (Source: in Object_Pointer) return Standard.Boolean is
|
||||
pragma Inline (Is_Symbol);
|
||||
begin
|
||||
return Is_Normal_Pointer (Source) and then
|
||||
Source.Tag = Symbol_Object;
|
||||
end Is_Symbol;
|
||||
|
||||
procedure Make_Symbol (Interp: in out Interpreter_Record;
|
||||
Source: in Object_String;
|
||||
Result: out Object_Pointer) is
|
||||
@ -811,49 +887,6 @@ Text_IO.Put_Line ("Creating a symbol .. " & Source);
|
||||
Print_Object_Pointer ("Make_Symbol Result - " & Source, Result);
|
||||
end Make_Symbol;
|
||||
|
||||
|
||||
procedure Make_Syntax (Interp: in out Interpreter_Record;
|
||||
Scode: in Syntax_Code;
|
||||
Name: in Object_String;
|
||||
Result: out Object_Pointer) is
|
||||
begin
|
||||
Make_Symbol (Interp, Name, Result);
|
||||
Result.Flags := Result.Flags or Syntax_Object;
|
||||
Result.Scode := Scode;
|
||||
Text_IO.Put ("Creating Syntax Symbol ");
|
||||
Put_String (To_Thin_String_Pointer (Result));
|
||||
end Make_Syntax;
|
||||
|
||||
procedure Make_Procedure (Interp: in out Interpreter_Record;
|
||||
Name: in Object_String;
|
||||
Result: out Object_Pointer) is
|
||||
begin
|
||||
null;
|
||||
end Make_Procedure;
|
||||
|
||||
procedure Make_Frame (Interp: in out Interpreter_Record;
|
||||
Stack: in Object_Pointer; -- current stack pointer
|
||||
Opcode: in Object_Pointer;
|
||||
Operand: in Object_Pointer;
|
||||
Result: out Object_Pointer) is
|
||||
begin
|
||||
Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer, Result);
|
||||
Result.Tag := Frame_Object;
|
||||
Result.Pointer_Slot(Frame_Stack_Index) := Stack;
|
||||
Result.Pointer_Slot(Frame_Opcode_Index) := Opcode;
|
||||
Result.Pointer_Slot(Frame_Operand_Index) := Operand;
|
||||
--Print_Object_Pointer ("Make_Frame Result - ", Result);
|
||||
end Make_Frame;
|
||||
|
||||
function Make_Cons (Interp: access Interpreter_Record;
|
||||
Car: in Object_Pointer;
|
||||
Cdr: in Object_Pointer) return Object_Pointer is
|
||||
Result: Object_Pointer;
|
||||
begin
|
||||
Make_Cons (Interp.all, Car, Cdr, Result);
|
||||
return Result;
|
||||
end Make_Cons;
|
||||
|
||||
function Make_Symbol (Interp: access Interpreter_Record;
|
||||
Source: in Object_String) return Object_Pointer is
|
||||
Result: Object_Pointer;
|
||||
@ -862,16 +895,229 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
return Result;
|
||||
end Make_Symbol;
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
-- TODO: change environment implementation to a table from a list
|
||||
procedure Add_To_Environment (Interp: in out Interpreter_Record;
|
||||
Envir: in out Object_Pointer;
|
||||
Key: in Object_Pointer;
|
||||
Value: in Object_Pointer) is
|
||||
-- This performs no duplicate key check.
|
||||
-- TODO: make environemnt a table instead of a list.
|
||||
Pair: Object_Pointer;
|
||||
begin
|
||||
pragma Assert (Is_Symbol(Key));
|
||||
|
||||
-- TODO: make temporaries GC-aware
|
||||
Pair := Make_Cons (Interp.Self, Key, Value);
|
||||
Envir := Make_Cons (Interp.Self, Pair, Envir);
|
||||
end Add_To_Environment;
|
||||
|
||||
function Get_Environment_Cons (Interp: access Interpreter_Record;
|
||||
Envir: in Object_Pointer;
|
||||
Key: in Object_Pointer) return Object_Pointer is
|
||||
Ptr: Object_Pointer := Envir;
|
||||
Cons: Object_Pointer;
|
||||
begin
|
||||
Print_Object_Pointer ("Get_Environment Key => ", Key);
|
||||
while Ptr /= Nil_Pointer loop
|
||||
pragma Assert (Is_Cons(Ptr));
|
||||
|
||||
Cons := Get_Car(Ptr);
|
||||
pragma Assert (Is_Cons(Cons));
|
||||
if Get_Car(Cons) = Key then
|
||||
return Cons;
|
||||
end if;
|
||||
|
||||
Ptr := Get_Cdr(Ptr);
|
||||
end loop;
|
||||
|
||||
return null; -- not found. note that it's not Nil_Pointer.
|
||||
end Get_Environment_Cons;
|
||||
|
||||
function Get_Environment (Interp: access Interpreter_Record;
|
||||
Envir: in Object_Pointer;
|
||||
Key: in Object_Pointer) return Object_Pointer is
|
||||
Cons: Object_Pointer;
|
||||
begin
|
||||
Cons := Get_Environment_Cons(Interp, Envir, Key);
|
||||
if Cons = null then
|
||||
return null;
|
||||
end if;
|
||||
return Get_Cdr(Cons);
|
||||
end Get_Environment;
|
||||
|
||||
procedure Set_Environment (Interp: in out Interpreter_Record;
|
||||
Envir: in out Object_Pointer;
|
||||
Key: in Object_Pointer;
|
||||
Value: in Object_Pointer) is
|
||||
Cons: Object_Pointer;
|
||||
begin
|
||||
Cons := Get_Environment_Cons (Interp.Self, Envir, Key);
|
||||
if Cons = null then
|
||||
-- add a new pair
|
||||
Add_To_Environment (Interp, Envir, Key, Value);
|
||||
else
|
||||
-- overwrite an existing pair
|
||||
Set_Cdr (Cons, Value);
|
||||
end if;
|
||||
end Set_Environment;
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
function Is_Syntax (Source: in Object_Pointer) return Standard.Boolean is
|
||||
begin
|
||||
return Is_Symbol(Source) and then (Source.Flags and Syntax_Object) /= 0;
|
||||
end Is_Syntax;
|
||||
|
||||
procedure Make_Syntax (Interp: in out Interpreter_Record;
|
||||
Opcode: in Syntax_Code;
|
||||
Name: in Object_String;
|
||||
Result: out Object_Pointer) is
|
||||
begin
|
||||
Make_Symbol (Interp, Name, Result);
|
||||
Result.Flags := Result.Flags or Syntax_Object;
|
||||
Result.Scode := Opcode;
|
||||
Text_IO.Put ("Creating Syntax Symbol ");
|
||||
Put_String (To_Thin_String_Pointer (Result));
|
||||
end Make_Syntax;
|
||||
|
||||
procedure Make_Procedure (Interp: in out Interpreter_Record;
|
||||
Opcode: in Procedure_Code;
|
||||
Name: in Object_String;
|
||||
Result: out Object_Pointer) is
|
||||
-- this procedure is for internal use only
|
||||
Symbol: Object_Pointer;
|
||||
Proc: Object_Pointer;
|
||||
begin
|
||||
-- TODO: make temporaries GC-aware
|
||||
-- Make a symbol for the procedure
|
||||
Make_Symbol (Interp, Name, Symbol);
|
||||
|
||||
-- Make the actual procedure object
|
||||
Allocate_Pointer_Object (Interp, Procedure_Object_Size, Nil_Pointer, Proc);
|
||||
Proc.Tag := Procedure_Object;
|
||||
Proc.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode);
|
||||
|
||||
-- Link it to the top environement
|
||||
pragma Assert (Get_Environment (Interp.Self, Interp.Root_Environment, Symbol) = null);
|
||||
Set_Environment (Interp, Interp.Root_Environment, Symbol, Proc);
|
||||
|
||||
-- Set the procudure to the result.
|
||||
Result := Proc;
|
||||
end Make_Procedure;
|
||||
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
function Is_Frame (Source: in Object_Pointer) return Standard.Boolean is
|
||||
pragma Inline (Is_Frame);
|
||||
begin
|
||||
return Is_Normal_Pointer (Source) and then
|
||||
Source.Tag = Frame_Object;
|
||||
end Is_Frame;
|
||||
|
||||
procedure Make_Frame (Interp: in out Interpreter_Record;
|
||||
Stack: in Object_Pointer; -- current stack pointer
|
||||
Opcode: in Object_Pointer;
|
||||
Operand: in Object_Pointer;
|
||||
Envir: in Object_Pointer;
|
||||
Result: out Object_Pointer) is
|
||||
begin
|
||||
Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer, Result);
|
||||
Result.Tag := Frame_Object;
|
||||
Result.Pointer_Slot(Frame_Stack_Index) := Stack;
|
||||
Result.Pointer_Slot(Frame_Opcode_Index) := Opcode;
|
||||
Result.Pointer_Slot(Frame_Operand_Index) := Operand;
|
||||
Result.Pointer_Slot(Frame_Environment_Index) := Envir;
|
||||
--Print_Object_Pointer ("Make_Frame Result - ", Result);
|
||||
end Make_Frame;
|
||||
|
||||
function Make_Frame (Interp: access Interpreter_Record;
|
||||
Stack: in Object_Pointer;
|
||||
Opcode: in Object_Pointer;
|
||||
Operand: in Object_Pointer) return Object_Pointer is
|
||||
Result: Object_Pointer;
|
||||
Operand: in Object_Pointer;
|
||||
Envir: in Object_Pointer) return Object_Pointer is
|
||||
Frame: Object_Pointer;
|
||||
begin
|
||||
Make_Frame (Interp.all, Stack, Opcode, Operand, Result);
|
||||
return Result;
|
||||
Make_Frame (Interp.all, Stack, Opcode, Operand, Envir, Frame);
|
||||
return Frame;
|
||||
end Make_Frame;
|
||||
|
||||
function Get_Frame_Return (Frame: in Object_Pointer) return Object_Pointer is
|
||||
pragma Inline (Get_Frame_Return);
|
||||
begin
|
||||
pragma Assert (Is_Frame(Frame));
|
||||
return Frame.Pointer_Slot(Frame_Return_Index);
|
||||
end Get_Frame_Return;
|
||||
|
||||
procedure Set_Frame_Return (Frame: in out Object_Pointer;
|
||||
Value: in Object_Pointer) is
|
||||
pragma Inline (Set_Frame_Return);
|
||||
begin
|
||||
pragma Assert (Is_Frame(Frame));
|
||||
Frame.Pointer_Slot(Frame_Return_Index) := Value;
|
||||
end Set_Frame_Return;
|
||||
|
||||
function Get_Frame_Environment (Frame: in Object_Pointer) return Object_Pointer is
|
||||
pragma Inline (Get_Frame_Environment);
|
||||
begin
|
||||
pragma Assert (Is_Frame(Frame));
|
||||
return Frame.Pointer_Slot(Frame_Environment_Index);
|
||||
end Get_Frame_Environment;
|
||||
|
||||
function Get_Frame_Opcode (Frame: in Object_Pointer) return Opcode_Type is
|
||||
pragma Inline (Get_Frame_Opcode);
|
||||
begin
|
||||
pragma Assert (Is_Frame(Frame));
|
||||
return Pointer_To_Integer(Frame.Pointer_Slot(Frame_Opcode_Index));
|
||||
end Get_Frame_Opcode;
|
||||
|
||||
procedure Set_Frame_Opcode (Frame: in Object_Pointer;
|
||||
OpcodE: in Opcode_Type) is
|
||||
pragma Inline (Set_Frame_Opcode);
|
||||
begin
|
||||
pragma Assert (Is_Frame(Frame));
|
||||
Frame.Pointer_Slot(Frame_Opcode_Index) := Integer_To_Pointer(Opcode);
|
||||
end Set_Frame_Opcode;
|
||||
|
||||
function Get_Frame_Operand (Frame: in Object_Pointer) return Object_Pointer is
|
||||
pragma Inline (Get_Frame_Operand);
|
||||
begin
|
||||
pragma Assert (Is_Frame(Frame));
|
||||
return Frame.Pointer_Slot(Frame_Operand_Index);
|
||||
end Get_Frame_Operand;
|
||||
|
||||
procedure Set_Frame_Operand (Frame: in out Object_Pointer;
|
||||
Value: in Object_Pointer) is
|
||||
pragma Inline (Set_Frame_Operand);
|
||||
begin
|
||||
pragma Assert (Is_Frame(Frame));
|
||||
Frame.Pointer_Slot(Frame_Operand_Index) := Value;
|
||||
end Set_Frame_Operand;
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
procedure Make_Closure (Interp: in out Interpreter_Record;
|
||||
Code: in Object_Pointer;
|
||||
Envir: in Object_Pointer;
|
||||
Result: out Object_Pointer) is
|
||||
begin
|
||||
Allocate_Pointer_Object (Interp, Closure_Object_Size, Nil_Pointer, Result);
|
||||
Result.Tag := Closure_Object;
|
||||
Result.Pointer_Slot(Closure_Code_Index) := Code;
|
||||
Result.Pointer_Slot(Closure_Environment_Index) := Envir;
|
||||
end Make_Closure;
|
||||
|
||||
function Make_Closure (Interp: access Interpreter_Record;
|
||||
Code: in Object_Pointer;
|
||||
Envir: in Object_Pointer) return Object_Pointer is
|
||||
Closure: Object_Pointer;
|
||||
begin
|
||||
Make_Closure (Interp.all, Code, Envir, Closure);
|
||||
return Closure;
|
||||
end Make_Closure;
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is
|
||||
begin
|
||||
@ -923,20 +1169,33 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
procedure Make_Syntax_Objects is
|
||||
Dummy: Object_Pointer;
|
||||
begin
|
||||
Make_Syntax (Interp, AND_SYNTAX, "and", Dummy);
|
||||
Make_Syntax (Interp, BEGIN_SYNTAX, "begin", Dummy);
|
||||
Make_Syntax (Interp, CASE_SYNTAX, "case", Dummy);
|
||||
Make_Syntax (Interp, COND_SYNTAX, "cond", Dummy);
|
||||
Make_Syntax (Interp, DEFINE_SYNTAX, "define", Dummy);
|
||||
Make_Syntax (Interp, IF_SYNTAX, "if", Dummy);
|
||||
Make_Syntax (Interp, LAMBDA_SYNTAX, "lambda", Dummy);
|
||||
Make_Syntax (Interp, LET_SYNTAX, "let", Dummy);
|
||||
Make_Syntax (Interp, LETAST_SYNTAX, "let*", Dummy);
|
||||
Make_Syntax (Interp, LETREC_SYNTAX, "letrec", Dummy);
|
||||
Make_Syntax (Interp, OR_SYNTAX, "or", Dummy);
|
||||
Make_Syntax (Interp, QUOTE_SYNTAX, "quote", Dummy);
|
||||
Make_Syntax (Interp, SET_SYNTAX, "set!", Dummy);
|
||||
Make_Syntax (Interp, And_Syntax, "and", Dummy);
|
||||
Make_Syntax (Interp, Begin_Syntax, "begin", Dummy);
|
||||
Make_Syntax (Interp, Case_Syntax, "case", Dummy);
|
||||
Make_Syntax (Interp, Cond_Syntax, "cond", Dummy);
|
||||
Make_Syntax (Interp, Define_Syntax, "define", Dummy);
|
||||
Make_Syntax (Interp, If_Syntax, "if", Dummy);
|
||||
Make_Syntax (Interp, Lambda_Syntax, "lambda", Dummy);
|
||||
Make_Syntax (Interp, Let_Syntax, "let", Dummy);
|
||||
Make_Syntax (Interp, Letast_Syntax, "let*", Dummy);
|
||||
Make_Syntax (Interp, Letrec_Syntax, "letrec", Dummy);
|
||||
Make_Syntax (Interp, Or_Syntax, "or", Dummy);
|
||||
Make_Syntax (Interp, Quote_Syntax, "quote", Dummy);
|
||||
Make_Syntax (Interp, Set_Syntax, "set!", Dummy);
|
||||
end Make_Syntax_Objects;
|
||||
|
||||
procedure Make_Procedure_Objects is
|
||||
Dummy: Object_Pointer;
|
||||
begin
|
||||
Make_Procedure (Interp, Car_Procedure, "car", Dummy);
|
||||
Make_Procedure (Interp, Cdr_Procedure, "cdr", Dummy);
|
||||
Make_Procedure (Interp, Setcar_Procedure, "setcar", Dummy);
|
||||
Make_Procedure (Interp, Setcdr_Procedure, "setcdr", Dummy);
|
||||
Make_Procedure (Interp, Add_Procedure, "+", Dummy);
|
||||
Make_Procedure (Interp, Subtract_Procedure, "-", Dummy);
|
||||
Make_Procedure (Interp, Multiply_Procedure, "*", Dummy);
|
||||
Make_Procedure (Interp, Divide_Procedure, "/", Dummy);
|
||||
end Make_Procedure_Objects;
|
||||
begin
|
||||
declare
|
||||
Aliased_Interp: aliased Interpreter_Record;
|
||||
@ -963,12 +1222,16 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
Interp.Storage_Pool := Storage_Pool;
|
||||
Interp.Root_Table := Nil_Pointer;
|
||||
Interp.Symbol_Table := Nil_Pointer;
|
||||
Interp.Environment := Nil_Pointer;
|
||||
Interp.Root_Environment := Nil_Pointer;
|
||||
Interp.Environment := Interp.Root_Environment;
|
||||
|
||||
Interp.Line_Pos := Interp.Line'First - 1;
|
||||
Interp.Line_Last := Interp.Line'First - 1;
|
||||
|
||||
-- TODO: disallow garbage collecion during initialization.
|
||||
Initialize_Heap (Initial_Heap_Size);
|
||||
Make_Syntax_Objects;
|
||||
|
||||
Make_Procedure_Objects;
|
||||
exception
|
||||
when others =>
|
||||
Deinitialize_Heap (Interp);
|
||||
@ -997,6 +1260,52 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
end case;
|
||||
end Get_Option;
|
||||
|
||||
procedure Read (Interp: in out Interpreter_Record;
|
||||
Result: out Object_Pointer) is
|
||||
|
||||
EOF_Error: exception;
|
||||
|
||||
function Get_Character return Object_Character is
|
||||
begin
|
||||
if Interp.Line_Pos >= Interp.Line_Last then
|
||||
if Text_IO.End_Of_File then
|
||||
raise EOF_Error;
|
||||
end if;
|
||||
Text_IO.Get_Line (Interp.Line, Interp.Line_Last);
|
||||
Interp.Line_Pos := Interp.Line'First - 1;
|
||||
end if;
|
||||
|
||||
Interp.Line_Pos := Interp.Line_Pos + 1;
|
||||
return Interp.Line(Interp.Line_Pos);
|
||||
end Get_Character;
|
||||
|
||||
procedure Skip_Space is
|
||||
begin
|
||||
null;
|
||||
end Skip_Space;
|
||||
|
||||
--function Get_Token is
|
||||
--begin
|
||||
-- null;
|
||||
--end Get_Token;
|
||||
|
||||
procedure Read_Atom (Atom: out Object_Pointer) is
|
||||
begin
|
||||
null;
|
||||
end Read_Atom;
|
||||
|
||||
Stack: Object_Pointer;
|
||||
Opcode: Object_Integer;
|
||||
Operand: Object_Pointer;
|
||||
begin
|
||||
--Opcode := 1;
|
||||
--loop
|
||||
-- case Opcode is
|
||||
-- when 1 =>
|
||||
--end loop;
|
||||
null;
|
||||
end Read;
|
||||
|
||||
procedure Print (Interp: in out Interpreter_Record;
|
||||
Source: in Object_Pointer) is
|
||||
|
||||
@ -1034,6 +1343,9 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
when Continuation_Object =>
|
||||
Text_IO.Put ("#Continuation");
|
||||
|
||||
when Procedure_Object =>
|
||||
Text_IO.Put ("#Procedure");
|
||||
|
||||
when Others =>
|
||||
if Atom.Kind = Character_Object then
|
||||
Text_IO.Put (To_String (Atom.Character_Slot));
|
||||
@ -1063,7 +1375,7 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
end Print_Byte;
|
||||
|
||||
begin
|
||||
Ptr_Type := Get_Pointer_Type (Atom);
|
||||
Ptr_Type := Get_Pointer_Type(Atom);
|
||||
case Ptr_Type is
|
||||
when Object_Pointer_Type_Pointer =>
|
||||
Print_Pointee;
|
||||
@ -1090,7 +1402,7 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
Text_IO.Put ("(");
|
||||
|
||||
loop
|
||||
Car := Cons.Pointer_Slot (Cons_Car_Index);
|
||||
Car := Get_Car(Cons);
|
||||
|
||||
if Is_Cons (Car) then
|
||||
Print_Object (Car);
|
||||
@ -1098,7 +1410,7 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
Print_Atom (Car);
|
||||
end if;
|
||||
|
||||
Cdr := Cons.Pointer_Slot (Cons_Cdr_Index);
|
||||
Cdr := Get_Cdr(Cons);
|
||||
if Is_Cons (Cdr) then
|
||||
Text_IO.Put (" ");
|
||||
Cons := Cdr;
|
||||
@ -1119,7 +1431,7 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
end Print_Object;
|
||||
|
||||
|
||||
Stack: Object_Pointer;
|
||||
Stack: Object_Pointer; -- TODO: make it into the interpreter_Record so that GC can workd
|
||||
Opcode: Object_Integer;
|
||||
Operand: Object_Pointer;
|
||||
|
||||
@ -1127,23 +1439,25 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
-- TODO: Let Make_Frame use a dedicated stack space that's apart from the heap.
|
||||
-- This way, the stack frame doesn't have to be managed by GC.
|
||||
|
||||
Stack := Make_Frame (Interp.Self, Nil_Pointer, Integer_To_Pointer(0), Nil_Pointer, Interp.Root_Environment); -- just for get_frame_environment...
|
||||
|
||||
Opcode := 1;
|
||||
Operand := Source;
|
||||
Stack := Nil_Pointer; -- make it to the interpreter so that GC can work
|
||||
|
||||
loop
|
||||
case Opcode is
|
||||
when 1 =>
|
||||
if Is_Cons(Operand) then
|
||||
-- push cdr
|
||||
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Operand.Pointer_Slot(Cons_Cdr_Index)); -- push cdr
|
||||
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Get_Frame_Environment(Stack)); -- push cdr
|
||||
Text_IO.Put ("(");
|
||||
Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car
|
||||
Operand := Get_Car(Operand);
|
||||
Opcode := 1;
|
||||
else
|
||||
Print_Atom (Operand);
|
||||
if Stack = Nil_Pointer then
|
||||
Opcode := 0;
|
||||
Opcode := 0; -- stack empty. arrange to exit
|
||||
Operand := True_Pointer; -- return value
|
||||
else
|
||||
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
|
||||
Operand := Stack.Pointer_Slot(Frame_Operand_Index);
|
||||
@ -1155,9 +1469,9 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
|
||||
if Is_Cons(Operand) then
|
||||
-- push cdr
|
||||
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Operand.Pointer_Slot(Cons_Cdr_Index)); -- push
|
||||
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Get_Frame_Environment(Stack)); -- push
|
||||
Text_IO.Put (" ");
|
||||
Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car
|
||||
Operand := Get_Car(Operand); -- car
|
||||
Opcode := 1;
|
||||
else
|
||||
if Operand /= Nil_Pointer then
|
||||
@ -1168,7 +1482,7 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
Text_IO.Put (")");
|
||||
|
||||
if Stack = Nil_Pointer then
|
||||
Opcode := 0;
|
||||
Opcode := 0; -- stack empty. arrange to exit
|
||||
else
|
||||
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
|
||||
Operand := Stack.Pointer_Slot(Frame_Operand_Index);
|
||||
@ -1185,7 +1499,7 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
Text_IO.New_Line;
|
||||
end Print;
|
||||
|
||||
procedure Evaluate (Interp: in out Interpreter_Record) is
|
||||
procedure Evaluatex (Interp: in out Interpreter_Record) is
|
||||
X: Object_Pointer;
|
||||
begin
|
||||
--Make_Cons (Interpreter, Nil_Pointer, Nil_Pointer, X);
|
||||
@ -1217,9 +1531,242 @@ Make_Symbol (Interp, "lambda", Interp.Root_Table);
|
||||
|
||||
--X := Make_Cons (Interp.Self, Nil_Pointer, Make_Cons (Interp.Self, Nil_Pointer, Integer_To_Pointer(TEN)));
|
||||
--X := Make_Cons (Interp.Self, Nil_Pointer, Nil_Pointer);
|
||||
Read (Interp, X);
|
||||
Print (Interp, X);
|
||||
|
||||
end Evaluatex;
|
||||
|
||||
procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Object_Pointer) is
|
||||
begin
|
||||
--(define x 10)
|
||||
--Result := Make_Cons (
|
||||
-- Interp.Self,
|
||||
-- Make_Symbol (Interp.Self, "define"),
|
||||
-- Make_Cons (
|
||||
-- Interp.Self,
|
||||
-- Make_Symbol (Interp.Self, "x"),
|
||||
-- Make_Cons (
|
||||
-- Interp.Self,
|
||||
-- Integer_To_Pointer (10),
|
||||
-- --Nil_Pointer
|
||||
-- Integer_To_Pointer (10)
|
||||
-- )
|
||||
-- )
|
||||
--);
|
||||
|
||||
-- (+ 1 2 . 2)
|
||||
Result := Make_Cons (
|
||||
Interp.Self,
|
||||
Make_Symbol (Interp.Self, "+"),
|
||||
Make_Cons (
|
||||
Interp.Self,
|
||||
Integer_To_Pointer (10),
|
||||
Make_Cons (
|
||||
Interp.Self,
|
||||
Integer_To_Pointer (20),
|
||||
Integer_To_Pointer (2)
|
||||
)
|
||||
)
|
||||
);
|
||||
end Make_Test_Object;
|
||||
|
||||
|
||||
function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type is
|
||||
pragma Inline (Pointer_To_Opcode);
|
||||
begin
|
||||
return Pointer_To_Integer(Pointer);
|
||||
end Pointer_To_Opcode;
|
||||
|
||||
function Opcode_To_Pointer (Opcode: in Opcode_Type) return Object_Pointer is
|
||||
pragma Inline (Opcode_To_Pointer);
|
||||
begin
|
||||
return Integer_To_Pointer(Opcode);
|
||||
end Opcode_To_Pointer;
|
||||
|
||||
procedure Evaluate (Interp: in out Interpreter_Record;
|
||||
Source: in Object_Pointer;
|
||||
Result: out Object_Pointer) is
|
||||
|
||||
procedure Push_Frame (Stack: in out Object_Pointer;
|
||||
Opcode: in Opcode_Type;
|
||||
Operand: in Object_Pointer;
|
||||
Envir: in Object_Pointer) is
|
||||
pragma Inline (Push_Frame);
|
||||
begin
|
||||
Stack := Make_Frame (Interp.Self, Stack, Opcode_To_Pointer(Opcode), Operand, Envir);
|
||||
end Push_Frame;
|
||||
|
||||
--procedure Pop_Frame (Stack: out Object_Pointer;
|
||||
-- Opcode: out Opcode_Type;
|
||||
-- Operand: out Object_Pointer) is
|
||||
-- pragma Inline (Pop_Frame);
|
||||
--begin
|
||||
-- pragma Assert (Stack /= Nil_Pointer);
|
||||
-- Opcode := Pointer_To_Opcode(Stack.Pointer_Slot(Frame_Opcode_Index));
|
||||
-- Operand := Stack.Pointer_Slot(Frame_Operand_Index);
|
||||
-- Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop
|
||||
--end Pop_Frame;
|
||||
|
||||
procedure Pop_Frame (Stack: out Object_Pointer) is
|
||||
pragma Inline (Pop_Frame);
|
||||
begin
|
||||
pragma Assert (Stack /= Nil_Pointer);
|
||||
Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop
|
||||
end Pop_Frame;
|
||||
|
||||
procedure Evaluate_Object (Stack: in out Object_Pointer) is
|
||||
pragma Inline (Evaluate_Object);
|
||||
|
||||
Operand: Object_Pointer;
|
||||
Operand_Word: Object_Word;
|
||||
for Operand_Word'Address use Operand'Address;
|
||||
|
||||
Tmp: Object_Pointer;
|
||||
begin
|
||||
Text_IO.Put_Line ("Evaluate_Object...");
|
||||
Operand := Get_Frame_Operand (Stack);
|
||||
|
||||
if Get_Pointer_Type(Operand) /= Object_Pointer_Type_Pointer then
|
||||
Text_IO.Put_Line ("NON_POINTER...");
|
||||
goto Literal;
|
||||
end if;
|
||||
|
||||
Print_Object_Pointer ("Operand => ", Operand);
|
||||
case Operand_Word is
|
||||
when Nil_Word | True_Word | False_Word =>
|
||||
-- special literal object
|
||||
Text_IO.Put_Line ("SPECIAL POINTER...");
|
||||
goto Literal;
|
||||
|
||||
when others =>
|
||||
Text_IO.Put_Line ("OTHER BDONE.." & Object_Tag'Image(Operand.Tag));
|
||||
|
||||
case Operand.Tag is
|
||||
when Symbol_Object => -- Is_Symbol(Operand)
|
||||
Tmp := Get_Environment (Interp.Self, Get_Frame_Environment(Stack), Operand); -- TODO: use current environent
|
||||
if Tmp = null then
|
||||
-- unbound
|
||||
Text_IO.Put_Line ("Unbound symbol....");
|
||||
else
|
||||
-- symbol found in the environment
|
||||
Text_IO.Put_Line ("SUMBOL BDONE..");
|
||||
Operand := Tmp;
|
||||
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)
|
||||
Tmp := Get_Car(Operand);
|
||||
if Is_Syntax(Tmp) then
|
||||
Text_IO.Put_Line ("SYNTAX ..");
|
||||
-- special syntax symbol. normal evaluate rule doesn't
|
||||
-- apply for special syntax objects.
|
||||
--Opcode := Syntax_To_Opcode(Operand);
|
||||
Set_Frame_Opcode (Stack, Opcode_Evaluate_Syntax); -- switch to syntax evaluation
|
||||
else
|
||||
Text_IO.Put_Line ("NON_SYNTAX ..");
|
||||
declare
|
||||
Cdr: Object_Pointer := Get_Cdr(Operand);
|
||||
begin
|
||||
if Is_Cons(Cdr) then
|
||||
Set_Frame_Operand (Stack, Cdr); -- change the operand for the next call
|
||||
Push_Frame (Stack, Opcode_Evaluate_Object, Tmp, Get_Frame_Environment(Stack));
|
||||
else
|
||||
if Cdr /= Nil_Pointer then
|
||||
Text_IO.Put_Line ("..................FUCKING CDR.....................");
|
||||
end if;
|
||||
Operand := Get_Frame_Return(Stack);
|
||||
Set_Frame_Opcode (Stack, Opcode_Apply);
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
when others =>
|
||||
-- normal literal object
|
||||
Text_IO.Put_Line ("nORMAL LITERAL POINTER...");
|
||||
goto Literal;
|
||||
end case;
|
||||
end case;
|
||||
|
||||
return;
|
||||
|
||||
<<Literal>>
|
||||
Pop_Frame (Stack); -- done
|
||||
Print_Object_Pointer ("Return => ", Operand);
|
||||
Set_Frame_Return (Stack, Operand);
|
||||
end Evaluate_Object;
|
||||
|
||||
procedure Evaluate_Argument (Stack: in out Object_Pointer) is
|
||||
begin
|
||||
null;
|
||||
end Evaluate_Argument;
|
||||
|
||||
procedure Evaluate_Syntax (Stack: in out Object_Pointer) is
|
||||
Scode: Syntax_Code;
|
||||
begin
|
||||
Scode := Get_Car(Get_Frame_Operand(Stack)).Scode;
|
||||
case Scode is
|
||||
when Define_Syntax =>
|
||||
Text_IO.Put_Line ("define syntax");
|
||||
when others =>
|
||||
Text_IO.Put_Line ("Unknown syntax");
|
||||
end case;
|
||||
end Evaluate_Syntax;
|
||||
|
||||
procedure Evaluate_Procedure (Stack: in out Object_Pointer) is
|
||||
begin
|
||||
null;
|
||||
end Evaluate_Procedure;
|
||||
|
||||
procedure Apply (Stack: in out Object_Pointer) is
|
||||
begin
|
||||
null;
|
||||
end Apply;
|
||||
|
||||
Stack: Object_Pointer; -- TODO: make it into the interpreter_Record so that GC can workd
|
||||
|
||||
begin
|
||||
Stack := Nil_Pointer;
|
||||
|
||||
-- Push a pseudo-frame to terminate the evaluation loop
|
||||
Push_Frame (Stack, Opcode_Exit, Nil_Pointer, Interp.Root_Environment);
|
||||
|
||||
-- Push the actual frame for evaluation
|
||||
Push_Frame (Stack, Opcode_Evaluate_Object, Source, Interp.Root_Environment);
|
||||
|
||||
loop
|
||||
case Get_Frame_Opcode(Stack) is
|
||||
when Opcode_Evaluate_Object =>
|
||||
Evaluate_Object (Stack);
|
||||
|
||||
when Opcode_Evaluate_Argument =>
|
||||
Evaluate_Argument (Stack);
|
||||
|
||||
when Opcode_Evaluate_Syntax =>
|
||||
Evaluate_Syntax (Stack);
|
||||
|
||||
when Opcode_Evaluate_Procedure =>
|
||||
Evaluate_Procedure (Stack);
|
||||
|
||||
when Opcode_Apply =>
|
||||
Apply (Stack);
|
||||
|
||||
when Opcode_Exit =>
|
||||
Result := Get_Frame_Return (Stack);
|
||||
Pop_Frame (Stack);
|
||||
exit;
|
||||
end case;
|
||||
end loop;
|
||||
|
||||
-- the stack must be empty when the loop is terminated
|
||||
pragma Assert (Stack = Nil_Pointer);
|
||||
|
||||
end Evaluate;
|
||||
|
||||
|
||||
end H2.Scheme;
|
||||
|
||||
|
||||
|
||||
--(+ (+ 1 2) (+ 1 2))
|
||||
--push | eval | expr | result |
|
||||
|
||||
|
||||
|
||||
@ -126,20 +126,29 @@ package H2.Scheme is
|
||||
Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#);
|
||||
|
||||
type Syntax_Code is mod 2 ** 4;
|
||||
AND_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
BEGIN_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
CASE_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
COND_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
DEFINE_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
IF_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
LAMBDA_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
LET_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
LETAST_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
LETREC_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
OR_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
QUOTE_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
SET_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
|
||||
And_Syntax: constant Syntax_Code := Syntax_Code'(0);
|
||||
Begin_Syntax: constant Syntax_Code := Syntax_Code'(1);
|
||||
Case_Syntax: constant Syntax_Code := Syntax_Code'(2);
|
||||
Cond_Syntax: constant Syntax_Code := Syntax_Code'(3);
|
||||
Define_Syntax: constant Syntax_Code := Syntax_Code'(4);
|
||||
If_Syntax: constant Syntax_Code := Syntax_Code'(5);
|
||||
Lambda_Syntax: constant Syntax_Code := Syntax_Code'(6);
|
||||
Let_Syntax: constant Syntax_Code := Syntax_Code'(7);
|
||||
Letast_Syntax: constant Syntax_Code := Syntax_Code'(8);
|
||||
Letrec_Syntax: constant Syntax_Code := Syntax_Code'(9);
|
||||
Or_Syntax: constant Syntax_Code := Syntax_Code'(10);
|
||||
Quote_Syntax: constant Syntax_Code := Syntax_Code'(11);
|
||||
Set_Syntax: constant Syntax_Code := Syntax_Code'(12);
|
||||
|
||||
subtype Procedure_Code is Object_Integer;
|
||||
Car_Procedure: constant Procedure_Code := Procedure_Code'(0);
|
||||
Cdr_Procedure: constant Procedure_Code := Procedure_Code'(1);
|
||||
Setcar_Procedure: constant Procedure_Code := Procedure_Code'(2);
|
||||
Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(3);
|
||||
Add_Procedure: constant Procedure_Code := Procedure_Code'(4);
|
||||
Subtract_Procedure: constant Procedure_Code := Procedure_Code'(5);
|
||||
Multiply_Procedure: constant Procedure_Code := Procedure_Code'(6);
|
||||
Divide_Procedure: constant Procedure_Code := Procedure_Code'(7);
|
||||
|
||||
type Object_Tag is (
|
||||
Unknown_Object,
|
||||
@ -149,7 +158,8 @@ package H2.Scheme is
|
||||
Number_Object,
|
||||
Array_Object,
|
||||
Table_Object,
|
||||
Lambda_Object,
|
||||
Procedure_Object,
|
||||
Closure_Object,
|
||||
Continuation_Object,
|
||||
Frame_Object
|
||||
);
|
||||
@ -287,15 +297,38 @@ package H2.Scheme is
|
||||
|
||||
type Interpreter_Record is limited private;
|
||||
|
||||
type Interpreter_Text_IO_Record is abstract tagged null record;
|
||||
|
||||
procedure Open (IO: in out Interpreter_Text_IO_Record;
|
||||
Name: in Object_String) is abstract;
|
||||
|
||||
procedure Close (IO: in out Interpreter_Text_IO_Record) is abstract;
|
||||
|
||||
procedure Read (IO: in out Interpreter_Text_IO_Record;
|
||||
Data: in Object_String;
|
||||
Last: in Standard.Natural) is abstract;
|
||||
|
||||
procedure Write (IO: in out Interpreter_Text_IO_Record;
|
||||
Data: out Object_String;
|
||||
Last: out Standard.Natural) is abstract;
|
||||
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
|
||||
procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Object_Pointer);
|
||||
|
||||
procedure Open (Interp: in out Interpreter_Record;
|
||||
Initial_Heap_Size:in Memory_Size;
|
||||
Storage_Pool: in Storage_Pool_Pointer := null);
|
||||
|
||||
procedure Close (Interp: in out Interpreter_Record);
|
||||
|
||||
procedure Evaluate (Interp: in out Interpreter_Record);
|
||||
procedure Evaluate (Interp: in out Interpreter_Record;
|
||||
Source: in Object_Pointer;
|
||||
Result: out Object_Pointer);
|
||||
|
||||
procedure Print (Interp: in out Interpreter_Record;
|
||||
Source: in Object_Pointer);
|
||||
|
||||
procedure Set_Option (Interp: in out Interpreter_Record;
|
||||
Option: in Option_Record);
|
||||
@ -310,7 +343,7 @@ private
|
||||
type Heap_Array is array (Memory_Size range <>) of aliased Memory_Element;
|
||||
|
||||
type Heap_Record (Size: Memory_Size) is record
|
||||
Space: Heap_Array (1 .. Size) := (others => 0);
|
||||
Space: Heap_Array(1..Size) := (others => 0);
|
||||
Bound: Memory_Size := 0;
|
||||
end record;
|
||||
for Heap_Record'Alignment use Object_Pointer_Bytes;
|
||||
@ -327,20 +360,26 @@ private
|
||||
end record;
|
||||
|
||||
type Interpreter_Pointer is access all Interpreter_Record;
|
||||
--type Interpreter_Record is tagged limited record
|
||||
type Interpreter_Record is limited record
|
||||
Self: Interpreter_Pointer := null;
|
||||
Storage_Pool: Storage_Pool_Pointer := null;
|
||||
Trait: Option_Record (Trait_Option);
|
||||
Trait: Option_Record(Trait_Option);
|
||||
|
||||
Heap: Heap_Pointer_Array := (others => null);
|
||||
Current_Heap: Heap_Number := Heap_Number'First;
|
||||
|
||||
Root_Table: Object_Pointer := Nil_Pointer;
|
||||
Symbol_Table: Object_Pointer := Nil_Pointer;
|
||||
Root_Environment: Object_Pointer := Nil_Pointer;
|
||||
Environment: Object_Pointer := Nil_Pointer;
|
||||
Stack: Object_Pointer := Nil_Pointer;
|
||||
|
||||
R: Register_Record;
|
||||
|
||||
Line: Object_String(1..1024);
|
||||
Line_Last: Standard.Natural;
|
||||
Line_Pos: Standard.Natural;
|
||||
end record;
|
||||
|
||||
end H2.Scheme;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user