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

added some code to evaluate

Browse Source
This commit is contained in:
hyung-hwan 2013-12-17 16:04:55 +00:00
parent 0f96ff8851
commit d2b6a11da6
3 changed files with 757 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
cmd/scheme.adb
View File

@ -8,12 +8,18 @@ procedure scheme is
Pool: aliased Storage.Global_Pool; Pool: aliased Storage.Global_Pool;
SI: S.Interpreter_Record; SI: S.Interpreter_Record;
I: S.Object_Pointer;
O: S.Object_Pointer;
begin begin
Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Pointer_Bytes)); 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, 2_000_000, Pool'Unchecked_Access);
--S.Open (SI, null); --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); S.Close (SI);
declare declare

701
lib/h2-scheme.adb
View File

@ -20,6 +20,14 @@ package body H2.Scheme is
type Thin_Memory_Element_Array_Pointer is access all Thin_Memory_Element_Array; type Thin_Memory_Element_Array_Pointer is access all Thin_Memory_Element_Array;
for Thin_Memory_Element_Array_Pointer'Size use Object_Pointer_Bits; 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 -- COMMON OBJECTS
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@ -27,10 +35,19 @@ package body H2.Scheme is
Cons_Car_Index: constant Pointer_Object_Size := 1; Cons_Car_Index: constant Pointer_Object_Size := 1;
Cons_Cdr_Index: constant Pointer_Object_Size := 2; 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_Stack_Index: constant Pointer_Object_Size := 1;
Frame_Opcode_Index: constant Pointer_Object_Size := 2; Frame_Opcode_Index: constant Pointer_Object_Size := 2;
Frame_Operand_Index: constant Pointer_Object_Size := 3; Frame_Operand_Index: constant Pointer_Object_Size := 3;
Frame_Environment_Index: constant Pointer_Object_Size := 4;
Frame_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 Memory_Element_Pointer);
procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Object_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 procedure Print_Object_Pointer (Msg: in Object_String; Source: in Object_Pointer) is
W: Object_Word; W: Object_Word;
for W'Address use Source'Address; for W'Address use Source'Address;
Ptr_Type: Object_Pointer_Type;
begin 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)); Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W));
elsif Source.Kind = Character_Object then 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) & " - "); 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; Source.Tag = Cons_Object;
end Is_Cons; 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; procedure Make_Cons (Interp: in out Interpreter_Record;
Car: in Object_Pointer; Car: in Object_Pointer;
Cdr: in Object_Pointer; Cdr: in Object_Pointer;
@ -760,6 +818,17 @@ Text_IO.Put_Line (">>> [GC DONE]");
Print_Object_Pointer ("Make_Cons Result - ", Result); Print_Object_Pointer ("Make_Cons Result - ", Result);
end Make_Cons; 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; procedure Make_String (Interp: in out Interpreter_Record;
Source: in Object_String; Source: in Object_String;
Result: out Object_Pointer) is Result: out Object_Pointer) is
@ -769,6 +838,13 @@ Print_Object_Pointer ("Make_Cons Result - ", Result);
Print_Object_Pointer ("Make_String Result - " & Source, Result); Print_Object_Pointer ("Make_String Result - " & Source, Result);
end Make_String; 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; procedure Make_Symbol (Interp: in out Interpreter_Record;
Source: in Object_String; Source: in Object_String;
Result: out Object_Pointer) is 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); Print_Object_Pointer ("Make_Symbol Result - " & Source, Result);
end Make_Symbol; 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; function Make_Symbol (Interp: access Interpreter_Record;
Source: in Object_String) return Object_Pointer is Source: in Object_String) return Object_Pointer is
Result: Object_Pointer; Result: Object_Pointer;
@ -862,16 +895,229 @@ Put_String (To_Thin_String_Pointer (Result));
return Result; return Result;
end Make_Symbol; 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; function Make_Frame (Interp: access Interpreter_Record;
Stack: in Object_Pointer; Stack: in Object_Pointer;
Opcode: in Object_Pointer; Opcode: in Object_Pointer;
Operand: in Object_Pointer) return Object_Pointer is Operand: in Object_Pointer;
Result: Object_Pointer; Envir: in Object_Pointer) return Object_Pointer is
Frame: Object_Pointer;
begin begin
Make_Frame (Interp.all, Stack, Opcode, Operand, Result); Make_Frame (Interp.all, Stack, Opcode, Operand, Envir, Frame);
return Result; return Frame;
end Make_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 procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is
begin begin
@ -923,20 +1169,33 @@ Put_String (To_Thin_String_Pointer (Result));
procedure Make_Syntax_Objects is procedure Make_Syntax_Objects is
Dummy: Object_Pointer; Dummy: Object_Pointer;
begin begin
Make_Syntax (Interp, AND_SYNTAX, "and", Dummy); Make_Syntax (Interp, And_Syntax, "and", Dummy);
Make_Syntax (Interp, BEGIN_SYNTAX, "begin", Dummy); Make_Syntax (Interp, Begin_Syntax, "begin", Dummy);
Make_Syntax (Interp, CASE_SYNTAX, "case", Dummy); Make_Syntax (Interp, Case_Syntax, "case", Dummy);
Make_Syntax (Interp, COND_SYNTAX, "cond", Dummy); Make_Syntax (Interp, Cond_Syntax, "cond", Dummy);
Make_Syntax (Interp, DEFINE_SYNTAX, "define", Dummy); Make_Syntax (Interp, Define_Syntax, "define", Dummy);
Make_Syntax (Interp, IF_SYNTAX, "if", Dummy); Make_Syntax (Interp, If_Syntax, "if", Dummy);
Make_Syntax (Interp, LAMBDA_SYNTAX, "lambda", Dummy); Make_Syntax (Interp, Lambda_Syntax, "lambda", Dummy);
Make_Syntax (Interp, LET_SYNTAX, "let", Dummy); Make_Syntax (Interp, Let_Syntax, "let", Dummy);
Make_Syntax (Interp, LETAST_SYNTAX, "let*", Dummy); Make_Syntax (Interp, Letast_Syntax, "let*", Dummy);
Make_Syntax (Interp, LETREC_SYNTAX, "letrec", Dummy); Make_Syntax (Interp, Letrec_Syntax, "letrec", Dummy);
Make_Syntax (Interp, OR_SYNTAX, "or", Dummy); Make_Syntax (Interp, Or_Syntax, "or", Dummy);
Make_Syntax (Interp, QUOTE_SYNTAX, "quote", Dummy); Make_Syntax (Interp, Quote_Syntax, "quote", Dummy);
Make_Syntax (Interp, SET_SYNTAX, "set!", Dummy); Make_Syntax (Interp, Set_Syntax, "set!", Dummy);
end Make_Syntax_Objects; 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 begin
declare declare
Aliased_Interp: aliased Interpreter_Record; Aliased_Interp: aliased Interpreter_Record;
@ -963,12 +1222,16 @@ Put_String (To_Thin_String_Pointer (Result));
Interp.Storage_Pool := Storage_Pool; Interp.Storage_Pool := Storage_Pool;
Interp.Root_Table := Nil_Pointer; Interp.Root_Table := Nil_Pointer;
Interp.Symbol_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. -- TODO: disallow garbage collecion during initialization.
Initialize_Heap (Initial_Heap_Size); Initialize_Heap (Initial_Heap_Size);
Make_Syntax_Objects; Make_Syntax_Objects;
Make_Procedure_Objects;
exception exception
when others => when others =>
Deinitialize_Heap (Interp); Deinitialize_Heap (Interp);
@ -997,6 +1260,52 @@ Put_String (To_Thin_String_Pointer (Result));
end case; end case;
end Get_Option; 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; procedure Print (Interp: in out Interpreter_Record;
Source: in Object_Pointer) is Source: in Object_Pointer) is
@ -1034,6 +1343,9 @@ Put_String (To_Thin_String_Pointer (Result));
when Continuation_Object => when Continuation_Object =>
Text_IO.Put ("#Continuation"); Text_IO.Put ("#Continuation");
when Procedure_Object =>
Text_IO.Put ("#Procedure");
when Others => when Others =>
if Atom.Kind = Character_Object then if Atom.Kind = Character_Object then
Text_IO.Put (To_String (Atom.Character_Slot)); Text_IO.Put (To_String (Atom.Character_Slot));
@ -1063,7 +1375,7 @@ Put_String (To_Thin_String_Pointer (Result));
end Print_Byte; end Print_Byte;
begin begin
Ptr_Type := Get_Pointer_Type (Atom); Ptr_Type := Get_Pointer_Type(Atom);
case Ptr_Type is case Ptr_Type is
when Object_Pointer_Type_Pointer => when Object_Pointer_Type_Pointer =>
Print_Pointee; Print_Pointee;
@ -1090,7 +1402,7 @@ Put_String (To_Thin_String_Pointer (Result));
Text_IO.Put ("("); Text_IO.Put ("(");
loop loop
Car := Cons.Pointer_Slot (Cons_Car_Index); Car := Get_Car(Cons);
if Is_Cons (Car) then if Is_Cons (Car) then
Print_Object (Car); Print_Object (Car);
@ -1098,7 +1410,7 @@ Put_String (To_Thin_String_Pointer (Result));
Print_Atom (Car); Print_Atom (Car);
end if; end if;
Cdr := Cons.Pointer_Slot (Cons_Cdr_Index); Cdr := Get_Cdr(Cons);
if Is_Cons (Cdr) then if Is_Cons (Cdr) then
Text_IO.Put (" "); Text_IO.Put (" ");
Cons := Cdr; Cons := Cdr;
@ -1119,7 +1431,7 @@ Put_String (To_Thin_String_Pointer (Result));
end Print_Object; end Print_Object;
Stack: Object_Pointer; Stack: Object_Pointer; -- TODO: make it into the interpreter_Record so that GC can workd
Opcode: Object_Integer; Opcode: Object_Integer;
Operand: Object_Pointer; 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. -- 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. -- 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; Opcode := 1;
Operand := Source; Operand := Source;
Stack := Nil_Pointer; -- make it to the interpreter so that GC can work
loop loop
case Opcode is case Opcode is
when 1 => when 1 =>
if Is_Cons(Operand) then if Is_Cons(Operand) then
-- push cdr -- 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 ("("); Text_IO.Put ("(");
Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car Operand := Get_Car(Operand);
Opcode := 1; Opcode := 1;
else else
Print_Atom (Operand); Print_Atom (Operand);
if Stack = Nil_Pointer then if Stack = Nil_Pointer then
Opcode := 0; Opcode := 0; -- stack empty. arrange to exit
Operand := True_Pointer; -- return value
else else
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
Operand := Stack.Pointer_Slot(Frame_Operand_Index); Operand := Stack.Pointer_Slot(Frame_Operand_Index);
@ -1155,9 +1469,9 @@ Put_String (To_Thin_String_Pointer (Result));
if Is_Cons(Operand) then if Is_Cons(Operand) then
-- push cdr -- 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 (" "); Text_IO.Put (" ");
Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car Operand := Get_Car(Operand); -- car
Opcode := 1; Opcode := 1;
else else
if Operand /= Nil_Pointer then if Operand /= Nil_Pointer then
@ -1168,7 +1482,7 @@ Put_String (To_Thin_String_Pointer (Result));
Text_IO.Put (")"); Text_IO.Put (")");
if Stack = Nil_Pointer then if Stack = Nil_Pointer then
Opcode := 0; Opcode := 0; -- stack empty. arrange to exit
else else
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
Operand := Stack.Pointer_Slot(Frame_Operand_Index); Operand := Stack.Pointer_Slot(Frame_Operand_Index);
@ -1185,7 +1499,7 @@ Put_String (To_Thin_String_Pointer (Result));
Text_IO.New_Line; Text_IO.New_Line;
end Print; end Print;
procedure Evaluate (Interp: in out Interpreter_Record) is procedure Evaluatex (Interp: in out Interpreter_Record) is
X: Object_Pointer; X: Object_Pointer;
begin begin
--Make_Cons (Interpreter, Nil_Pointer, Nil_Pointer, X); --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, Make_Cons (Interp.Self, Nil_Pointer, Integer_To_Pointer(TEN)));
--X := Make_Cons (Interp.Self, Nil_Pointer, Nil_Pointer); --X := Make_Cons (Interp.Self, Nil_Pointer, Nil_Pointer);
Read (Interp, X);
Print (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 Evaluate;
end H2.Scheme; end H2.Scheme;
--(+ (+ 1 2) (+ 1 2))
--push | eval | expr | result |

73
lib/h2-scheme.ads
View File

@ -126,20 +126,29 @@ package H2.Scheme is
Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#); Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#);
type Syntax_Code is mod 2 ** 4; type Syntax_Code is mod 2 ** 4;
AND_SYNTAX: constant Syntax_Code := Syntax_Code'(0); And_Syntax: constant Syntax_Code := Syntax_Code'(0);
BEGIN_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Begin_Syntax: constant Syntax_Code := Syntax_Code'(1);
CASE_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Case_Syntax: constant Syntax_Code := Syntax_Code'(2);
COND_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Cond_Syntax: constant Syntax_Code := Syntax_Code'(3);
DEFINE_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Define_Syntax: constant Syntax_Code := Syntax_Code'(4);
IF_SYNTAX: constant Syntax_Code := Syntax_Code'(0); If_Syntax: constant Syntax_Code := Syntax_Code'(5);
LAMBDA_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Lambda_Syntax: constant Syntax_Code := Syntax_Code'(6);
LET_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Let_Syntax: constant Syntax_Code := Syntax_Code'(7);
LETAST_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Letast_Syntax: constant Syntax_Code := Syntax_Code'(8);
LETREC_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Letrec_Syntax: constant Syntax_Code := Syntax_Code'(9);
OR_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Or_Syntax: constant Syntax_Code := Syntax_Code'(10);
QUOTE_SYNTAX: constant Syntax_Code := Syntax_Code'(0); Quote_Syntax: constant Syntax_Code := Syntax_Code'(11);
SET_SYNTAX: constant Syntax_Code := Syntax_Code'(0); 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 ( type Object_Tag is (
Unknown_Object, Unknown_Object,
@ -149,7 +158,8 @@ package H2.Scheme is
Number_Object, Number_Object,
Array_Object, Array_Object,
Table_Object, Table_Object,
Lambda_Object, Procedure_Object,
Closure_Object,
Continuation_Object, Continuation_Object,
Frame_Object Frame_Object
); );
@ -287,15 +297,38 @@ package H2.Scheme is
type Interpreter_Record is limited private; 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; procedure Open (Interp: in out Interpreter_Record;
Initial_Heap_Size:in Memory_Size; Initial_Heap_Size:in Memory_Size;
Storage_Pool: in Storage_Pool_Pointer := null); Storage_Pool: in Storage_Pool_Pointer := null);
procedure Close (Interp: in out Interpreter_Record); 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; procedure Set_Option (Interp: in out Interpreter_Record;
Option: in Option_Record); Option: in Option_Record);
@ -310,7 +343,7 @@ private
type Heap_Array is array (Memory_Size range <>) of aliased Memory_Element; type Heap_Array is array (Memory_Size range <>) of aliased Memory_Element;
type Heap_Record (Size: Memory_Size) is record 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; Bound: Memory_Size := 0;
end record; end record;
for Heap_Record'Alignment use Object_Pointer_Bytes; for Heap_Record'Alignment use Object_Pointer_Bytes;
@ -327,20 +360,26 @@ private
end record; end record;
type Interpreter_Pointer is access all Interpreter_Record; type Interpreter_Pointer is access all Interpreter_Record;
--type Interpreter_Record is tagged limited record
type Interpreter_Record is limited record type Interpreter_Record is limited record
Self: Interpreter_Pointer := null; Self: Interpreter_Pointer := null;
Storage_Pool: Storage_Pool_Pointer := null; Storage_Pool: Storage_Pool_Pointer := null;
Trait: Option_Record (Trait_Option); Trait: Option_Record(Trait_Option);
Heap: Heap_Pointer_Array := (others => null); Heap: Heap_Pointer_Array := (others => null);
Current_Heap: Heap_Number := Heap_Number'First; Current_Heap: Heap_Number := Heap_Number'First;
Root_Table: Object_Pointer := Nil_Pointer; Root_Table: Object_Pointer := Nil_Pointer;
Symbol_Table: Object_Pointer := Nil_Pointer; Symbol_Table: Object_Pointer := Nil_Pointer;
Root_Environment: Object_Pointer := Nil_Pointer;
Environment: Object_Pointer := Nil_Pointer; Environment: Object_Pointer := Nil_Pointer;
Stack: Object_Pointer := Nil_Pointer; Stack: Object_Pointer := Nil_Pointer;
R: Register_Record; R: Register_Record;
Line: Object_String(1..1024);
Line_Last: Standard.Natural;
Line_Pos: Standard.Natural;
end record; end record;
end H2.Scheme; end H2.Scheme;