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

837
lib/h2-scheme.adb
View File

File diff suppressed because it is too large Load Diff

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;