added some code to evaluate

cmd/scheme.adb

@@ -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

lib/h2-scheme.ads

@@ -123,23 +123,32 @@ package H2.Scheme is
 	-- freely for management purpose. The Object_Flags type
 	-- represents the value that can be stored in this field.
 	type Object_Flags is mod 2 ** 4;
-	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;
-	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 (
 		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;