diff --git a/cmd/scheme.adb b/cmd/scheme.adb index e42cacc..aab0250 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -1,6 +1,9 @@ with H2.Scheme; +with H2.Pool; with Storage; +with Stream; with Ada.Text_IO; +with Ada.Unchecked_Deallocation; procedure scheme is package S renames H2.Scheme; @@ -10,12 +13,62 @@ procedure scheme is I: S.Object_Pointer; O: S.Object_Pointer; + + --String: aliased S.Object_String := "(car '(1 2 3))"; + String: aliased S.Object_String := "((lambda (x y) (+ x y)) 9 7)"; + String_Stream: Stream.String_Input_Stream_Record (String'Unchecked_Access); + --String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0); + + + File_Name: aliased S.Object_String := "test.adb"; + --File_Stream: Stream.File_Stream_Record (File_Name'Unchecked_Access); + --File_Stream: Stream.File_Stream_Record := (Name => File_Name'Unchecked_Access); + File_Stream: Stream.File_Stream_Record; + + procedure Allocate_Stream (Interp: in out S.Interpreter_Record; + Name: access S.Object_String; + Result: in out S.Stream_Pointer) is + subtype FSR is Stream.File_Stream_Record; + type FSP is access all FSR; + package P is new H2.Pool (FSR, FSP); + + X: FSP; + for X'Address use Result'Address; + pragma Import (Ada, X); + begin + X := P.Allocate (S.Get_Storage_Pool(Interp)); + X.Name := Stream.Object_String_Pointer(Name); + end Allocate_Stream; + + procedure Deallocate_Stream (Interp: in out S.Interpreter_Record; + Source: in out S.Stream_Pointer) is + subtype FSR is Stream.File_Stream_Record; + type FSP is access all FSR; + package P is new H2.Pool (FSR, FSP); + + X: FSP; + for X'Address use Source'Address; + pragma Import (Ada, X); + begin + P.Deallocate (X, S.Get_Storage_Pool(Interp)); + end Deallocate_Stream; + +-- --procedure Dealloc_Stream is new Ada.Unchecked_Deallocation (Stream_Record'Class, Stream_Pointer); +-- --procedure Destroy_Stream (Stream: in out Stream_Pointer) renames Dealloc_Stream; + + 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); + +File_Stream.Name := File_Name'Unchecked_Access; +S.Set_Input_Stream (SI, File_Stream); -- specify main input stream +--S.Set_Output_Stream (SI, Stream); -- specify main output stream. +S.Read (SI, I); S.Make_Test_Object (SI, I); + S.Evaluate (SI, I, O); S.Print (SI, I); Ada.Text_IO.Put_Line ("-------------------------------------------"); diff --git a/cmd/scheme.gpr.in b/cmd/scheme.gpr.in index 0bc4404..e2a8a6e 100644 --- a/cmd/scheme.gpr.in +++ b/cmd/scheme.gpr.in @@ -1,7 +1,7 @@ with "@abs_builddir@/../lib/libh2"; -project H2_Scheme is +project Scheme is for Main use ("scheme"); @@ -15,13 +15,15 @@ project H2_Scheme is for Source_Files use ( "storage.ads", "storage.adb", + "stream.ads", + "stream.adb", "scheme.adb" ); for Object_Dir use "@ADA_OBJDIR@"; package Compiler is for Default_Switches ("Ada") use ( - "-gnata", "-gnato", "-gnatN", "-gnatwl", + "-gnata", "-gnato", "-gnatN", "-gnatwl", "-gnat95" "-I@abs_srcdir@/../lib" ); end Compiler; @@ -30,6 +32,6 @@ project H2_Scheme is for Executable ("scheme.adb") use "h2scm"; end Builder; -end H2_Scheme; +end Scheme; diff --git a/cmd/stream.adb b/cmd/stream.adb new file mode 100644 index 0000000..2784345 --- /dev/null +++ b/cmd/stream.adb @@ -0,0 +1,87 @@ + +package body Stream is + + ------------------------------------------------------------------ + + procedure Open (Stream: in out String_Input_Stream_Record) is + begin +Ada.Text_IO.Put_Line ("OPEN STRING STREAM"); + Stream.Pos := 0; + end Open; + + procedure Close (Stream: in out String_Input_Stream_Record) is + begin +Ada.Text_IO.Put_Line ("CLOSE STRING STREAM"); + Stream.Pos := Stream.Str'Last; + end Close; + + procedure Read (Stream: in out String_Input_Stream_Record; + Data: out S.Object_String; + Last: out Standard.Natural) is + Avail: Standard.Natural; + begin + Avail := Stream.Str'Last - Stream.Pos; + if Avail <= 0 then + -- EOF + Last := Data'First - 1; + else + if Avail > Data'Length then + Avail := Data'Length; + end if; + + Data(Data'First .. Avail) := Stream.Str(Stream.Pos + 1..Stream.Pos + Avail); + Stream.Pos := Stream.Pos + Avail; + Last := Data'First + Avail - 1; + end if; + end Read; + + procedure Write (Stream: in out String_Input_Stream_Record; + Data: out S.Object_String; + Last: out Standard.Natural) is + begin + --raise S.Stream_Error; + Last := Data'First - 1; + end Write; + + ------------------------------------------------------------------ + + procedure Open (Stream: in out File_Stream_Record) is + begin +Ada.Text_IO.Put_Line ("OPEN File STREAM"); + Ada.Text_IO.Open (Stream.Handle, Ada.Text_IO.In_File, Stream.Name.all); + end Open; + + procedure Close (Stream: in out File_Stream_Record) is + begin +Ada.Text_IO.Put_Line ("CLOSE File STREAM"); + Ada.Text_IO.Close (Stream.Handle); + end Close; + + procedure Read (Stream: in out File_Stream_Record; + Data: out S.Object_String; + Last: out Standard.Natural) is + begin + for I in Data'First .. Data'Last loop + begin + Ada.Text_IO.Get_Immediate (Stream.Handle, Data(I)); + exception + when Ada.Text_IO.End_Error => + Last := I - 1; + return; + -- other exceptions must be just raised to indicate errors + end; + end loop; + Last := Data'Last; + end Read; + + procedure Write (Stream: in out File_Stream_Record; + Data: out S.Object_String; + Last: out Standard.Natural) is + begin + --raise S.Stream_Error; + Last := Data'First - 1; + end Write; + + ------------------------------------------------------------------ + +end Stream; diff --git a/cmd/stream.ads b/cmd/stream.ads new file mode 100644 index 0000000..7b24b02 --- /dev/null +++ b/cmd/stream.ads @@ -0,0 +1,48 @@ +with H2.Scheme; +with Ada.Text_IO; + +package Stream is + + package S renames H2.Scheme; + + ------------------------------------------------------------ + type Object_String_Pointer is access all S.Object_String; + type String_Input_Stream_Record(Str: Object_String_Pointer) is new S.Stream_Record with record + Pos: Standard.Natural := 0; + end record; + + --type String_Input_Stream_Record(Len: Standard.Natural) is new S.Stream_Record with record + -- Pos: Standard.Natural := 0; + -- Str: S.Object_String (1 .. Len) := (others => ' '); + --end record; + + procedure Open (Stream: in out String_Input_Stream_Record); + procedure Close (Stream: in out String_Input_Stream_Record); + procedure Read (Stream: in out String_Input_Stream_Record; + Data: out S.Object_String; + Last: out Standard.Natural); + procedure Write (Stream: in out String_Input_Stream_Record; + Data: out S.Object_String; + Last: out Standard.Natural); + + ------------------------------------------------------------ + --type File_Stream_Record(Name: Object_String_Pointer) is new S.Stream_Record with record + -- Handle: Ada.Text_IO.File_Type; + --end record; + + type File_Stream_Record is new S.Stream_Record with record + Name: Object_String_Pointer; + Handle: Ada.Text_IO.File_Type; + end record; + + procedure Open (Stream: in out File_Stream_Record); + procedure Close (Stream: in out File_Stream_Record); + procedure Read (Stream: in out File_Stream_Record; + Data: out S.Object_String; + Last: out Standard.Natural); + procedure Write (Stream: in out File_Stream_Record; + Data: out S.Object_String; + Last: out Standard.Natural); + +end Stream; + diff --git a/lib/h2-pool.adb b/lib/h2-pool.adb index a6a9b1d..34725dc 100644 --- a/lib/h2-pool.adb +++ b/lib/h2-pool.adb @@ -28,30 +28,30 @@ package body H2.Pool is end if; end Allocate; - function Allocate (Source: in Normal_Type; - Pool: in Storage_Pool_Pointer := null) return Pointer_Type is - P: Storage_Pool_Pointer; - begin - if Pool = null then - P := Storage_Pool; - else - P := Pool; - end if; - - if P = null then - return new Normal_Type'(Source); - else - declare - type Pooled_Pointer is access Normal_Type; - for Pooled_Pointer'Storage_Pool use P.all; - function To_Pointer_Type is new Ada.Unchecked_Conversion (Pooled_Pointer, Pointer_Type); - Tmp: Pooled_Pointer; - begin - Tmp := new Normal_Type'(Source); - return To_Pointer_Type (Tmp); - end; - end if; - end Allocate; +-- function Allocate (Source: in Normal_Type; +-- Pool: in Storage_Pool_Pointer := null) return Pointer_Type is +-- P: Storage_Pool_Pointer; +-- begin +-- if Pool = null then +-- P := Storage_Pool; +-- else +-- P := Pool; +-- end if; +-- +-- if P = null then +-- return new Normal_Type'(Source); +-- else +-- declare +-- type Pooled_Pointer is access Normal_Type; +-- for Pooled_Pointer'Storage_Pool use P.all; +-- function To_Pointer_Type is new Ada.Unchecked_Conversion (Pooled_Pointer, Pointer_Type); +-- Tmp: Pooled_Pointer; +-- begin +-- Tmp := new Normal_Type'(Source); +-- return To_Pointer_Type (Tmp); +-- end; +-- end if; +-- end Allocate; procedure Deallocate (Target: in out Pointer_Type; Pool: in Storage_Pool_Pointer := null) is diff --git a/lib/h2-pool.ads b/lib/h2-pool.ads index 2839777..91df370 100644 --- a/lib/h2-pool.ads +++ b/lib/h2-pool.ads @@ -7,16 +7,17 @@ -------------------------------------------------------------------- generic - type Normal_Type is private; - type Pointer_Type is access Normal_Type; + --type Normal_Type is private; + type Normal_Type is limited private; + type Pointer_Type is access all Normal_Type; Storage_Pool: in Storage_Pool_Pointer := null; package H2.Pool is function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type; - function Allocate (Source: in Normal_Type; - Pool: in Storage_Pool_Pointer := null) return Pointer_Type; +-- function Allocate (Source: in Normal_Type; +-- Pool: in Storage_Pool_Pointer := null) return Pointer_Type; procedure Deallocate (Target: in out Pointer_Type; Pool: in Storage_Pool_Pointer := null); diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index bfacb3d..b76ecdc 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -22,17 +22,21 @@ package body H2.Scheme is type Heap_Element_Pointer is access all Heap_Element; for Heap_Element_Pointer'Size use Object_Pointer_Bits; -- ensure that it can be overlayed by an ObjectPointer + type Thin_Heap_Element_Array is array (1 .. Heap_Size'Last) of Heap_Element; type Thin_Heap_Element_Array_Pointer is access all Thin_Heap_Element_Array; for Thin_Heap_Element_Array_Pointer'Size use Object_Pointer_Bits; - subtype Opcode_Type is Object_Integer range 0 .. 5; + subtype Moved_Object_Record is Object_Record (Moved_Object, 0); + + subtype Opcode_Type is Object_Integer range 0 .. 6; Opcode_Exit: constant Opcode_Type := Opcode_Type'(0); Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(1); Opcode_Evaluate_Group: 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); + Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(6); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -58,13 +62,10 @@ package body H2.Scheme is Closure_Code_Index: constant Pointer_Object_Size := 1; Closure_Environment_Index: constant Pointer_Object_Size := 2; - Pair_Object_Size: constant Pointer_Object_Size := 3; - Pair_Key_Size: constant Pointer_Object_Size := 1; - Pair_Value_Size: constant Pointer_Object_Size := 2; - Pair_Link_Size: constant Pointer_Object_Size := 3; - - procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Heap_Element_Pointer); - procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Object_Pointer); + procedure Set_New_Location (Object: in Object_Pointer; + Ptr: in Heap_Element_Pointer); + procedure Set_New_Location (Object: in Object_Pointer; + Ptr: in Object_Pointer); pragma Inline (Set_New_Location); function Get_New_Location (Object: in Object_Pointer) return Object_Pointer; @@ -117,7 +118,6 @@ package body H2.Scheme is return Get_Pointer_Type(Pointer) = Object_Pointer_Type_Byte; end Is_Byte; - function Integer_To_Pointer (Int: in Object_Integer) return Object_Pointer is Pointer: Object_Pointer; Word: Object_Word; @@ -389,7 +389,6 @@ package body H2.Scheme is -- object takes up the smallest space that a valid object can take. So -- it is safe to overlay it on any normal objects. procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Heap_Element_Pointer) is - subtype Moved_Object_Record is Object_Record (Moved_Object, 0); Moved_Object: Moved_Object_Record; for Moved_Object'Address use Object.all'Address; -- pramga Import must not be specified here as I'm counting @@ -402,7 +401,6 @@ package body H2.Scheme is end Set_New_Location; procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Object_Pointer) is - subtype Moved_Object_Record is Object_Record (Moved_Object, 0); Moved_Object: Moved_Object_Record; for Moved_Object'Address use Object.all'Address; --pragma Import (Ada, Moved_Object); -- this must not be used. @@ -419,14 +417,21 @@ package body H2.Scheme is Heap_Bytes: in Heap_Size) return Heap_Element_Pointer is Avail: Heap_Size; Result: Heap_Element_Pointer; + Real_Bytes: Heap_Size := Heap_Bytes; begin + if Real_Bytes < Moved_Object_Record'Max_Size_In_Storage_Elements then + -- Guarantee the minimum object size to be greater than or + -- equal to the size of a moved object for GC to work. + Real_Bytes := Moved_Object_Record'Max_Size_In_Storage_Elements; + end if; + Avail := Heap.Size - Heap.Bound; - if Heap_Bytes > Avail then + if Real_Bytes > Avail then return null; end if; Result := Heap.Space(Heap.Bound + 1)'Unchecked_Access; - Heap.Bound := Heap.Bound + Heap_Bytes; + Heap.Bound := Heap.Bound + Real_Bytes; return Result; end Allocate_Bytes_In_Heap; @@ -446,7 +451,7 @@ package body H2.Scheme is -- Target_Object_Record'Max_Size_In_Stroage_Elements were not -- always correct. For example, for a character object containing -- the string "lambda", Target_Object.all'Size returned 72 while - -- it's supposed to be 96. + -- it's supposed to be 96. Use Copy_Object_With_Size() below instead. Target_Object.all := Source.all; pragma Assert (Source.all'Size = Target_Object.all'Size); end Copy_Object; @@ -1313,6 +1318,7 @@ Put_String (To_Thin_String_Pointer (Result)); Heap := Pool.Allocate; end; end loop; + exception when others => Deinitialize_Heap (Interp); @@ -1376,33 +1382,60 @@ Put_String (To_Thin_String_Pointer (Result)); Interp.Root_Table := Nil_Pointer; Interp.Symbol_Table := Nil_Pointer; - Interp.Line_Pos := Interp.Line'First - 1; - Interp.Line_Last := Interp.Line'First - 1; + Interp.Input.Stream := null; + Interp.IO := Interp.Input'Unchecked_Access; -- TODO: disallow garbage collecion during initialization. +Text_IO.Put_Line ("1111111111"); Initialize_Heap (Initial_Heap_Size); Interp.Mark := Make_Mark (Interp.Self, 0); -- to indicate the end of cons evluation Interp.Root_Environment := Make_Environment (Interp.Self, Nil_Pointer); Interp.Environment := Interp.Root_Environment; Make_Syntax_Objects; Make_Procedure_Objects; +Text_IO.Put_Line ("99999"); exception when others => Deinitialize_Heap (Interp); end Open; + procedure Close_Stream (Stream: in out Stream_Pointer) is + begin + Close (Stream.all); + Stream := null; + exception + when others => + Stream := null; -- ignore exception + end Close_Stream; + + procedure Close_All_Streams (Interp: in out Interpreter_Record) is + begin + -- TODO: close all cascaded streams if any. + if Interp.Input.Stream /= null then + Close_Stream (Interp.Input.Stream); + end if; + end Close_All_Streams; + procedure Close (Interp: in out Interpreter_Record) is begin + Close_All_Streams (Interp); Deinitialize_Heap (Interp); end Close; + function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer is + begin + return Interp.Storage_Pool; + end Get_Storage_Pool; + procedure Set_Option (Interp: in out Interpreter_Record; Option: in Option_Record) is begin case Option.Kind is - when Trait_Option => + when Trait_Option => Interp.Trait := Option; + when Stream_Option => + Interp.Stream := Option; end case; end Set_Option; @@ -1410,36 +1443,123 @@ Put_String (To_Thin_String_Pointer (Result)); Option: in out Option_Record) is begin case Option.Kind is - when Trait_Option => + when Trait_Option => Option := Interp.Trait; + when Stream_Option => + Option := Interp.Stream; end case; end Get_Option; + procedure Set_Input_Stream (Interp: in out Interpreter_Record; + Stream: in out Stream_Record'Class) is + begin + --Open (Stream, Interp); + Open (Stream); + + -- if Open raised an exception, it wouldn't reach here. + -- so the existing stream still remains intact. + if Interp.Input.Stream /= null then + Close_Stream (Interp.Input.Stream); + end if; + + --Interp.Input := IO_Record'( + -- Stream => Stream'Unchecked_Access, + -- Data => (others => ' '), + -- Pos => Interp.Input.Data'First - 1, + -- Last => Interp.Input.Data'First - 1, + -- Flags => 0 + --); + Interp.Input.Stream := Stream'Unchecked_Access; + Interp.Input.Pos := Interp.Input.Data'First - 1; + Interp.Input.Last := Interp.Input.Data'First - 1; + Interp.Input.Flags := 0; + end Set_Input_Stream; + + --procedure Set_Output_Stream (Interp: in out Interpreter_Record; + -- Stream: in out Stream_Record'Class) is + --begin + -- + --end Set_Output_Stream; + + procedure Start_Input_Stream (Interp: in out Interpreter_Record; + Name: access Object_String) is + package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool); + IO: IO_Pointer; + begin + IO := IO_Pool.Allocate; + begin + Interp.Stream.Allocate (Interp, Name, IO.Stream); + exception + when others => + IO_Pool.Deallocate (IO); + raise; + end; + + begin + Open (IO.Stream.all); + exception + when others => + Interp.Stream.Deallocate (Interp, IO.Stream); + IO_Pool.Deallocate (IO); + raise; + end; + IO.Pos := IO.Data'First - 1; + IO.Last := IO.Data'First - 1; + IO.Flags := 0; + + IO.Next := Interp.IO; + Interp.IO := IO; + end Start_Input_Stream; + + procedure Stop_Input_Stream (Interp: in out Interpreter_Record) is + package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool); + IO: IO_Pointer; + begin + pragma Assert (Interp.IO /= Interp.Input'Unchecked_Access); + IO := Interp.IO; + Interp.IO := IO.Next; + + Interp.Stream.Deallocate (Interp, IO.Stream); + IO_Pool.Deallocate (IO); + end Stop_Input_Stream; + procedure Read (Interp: in out Interpreter_Record; Result: out Object_Pointer) is - EOF_Error: exception; + End_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; + -- TODO: calculate Interp.Input.Row, Interp.Input.Column + if Interp.Input.Pos >= Interp.Input.Last then + if Interp.Input.Flags /= 0 then + -- an error has occurred previously. + raise End_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); + Interp.Input.Pos := Interp.Input.Data'First - 1; + begin + Read (Interp.Input.Stream.all, Interp.Input.Data, Interp.Input.Last); + exception + when others => + Interp.Input.Flags := Interp.Input.Flags and IO_Error_Occurred; + raise End_Error; -- TODO: change the exception name + end; + if Interp.Input.Last < Interp.Input.Data'First then + Interp.Input.Flags := Interp.Input.Flags and IO_End_Reached; + raise End_Error; + end if; + end if; + Interp.Input.Pos := Interp.Input.Pos + 1; + return Interp.Input.Data(Interp.Input.Pos); end Get_Character; procedure Skip_Space is begin null; end Skip_Space; - - --function Get_Token is + + --function Get_Token return Token_Type is --begin -- null; --end Get_Token; @@ -1452,13 +1572,23 @@ Put_String (To_Thin_String_Pointer (Result)); Stack: Object_Pointer; Opcode: Object_Integer; Operand: Object_Pointer; + + C: Object_Character; begin --Opcode := 1; --loop -- case Opcode is -- when 1 => --end loop; - null; + loop + C := Get_Character; + Text_IO.Put (C); + end loop; + + exception + when End_Error => + TEXT_IO.New_Line; + Text_IO.Put_Line ("END OF INPUT..."); end Read; procedure Print (Interp: in out Interpreter_Record; @@ -1694,7 +1824,7 @@ Interp.Root_Table := Make_Symbol (Interp.Self, "lambda"); --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); + --Read (Interp, X); Print (Interp, X); end Evaluatex; @@ -2301,6 +2431,62 @@ Print (Interp, Operand); end case; end Apply; + procedure Read_Object is + +-- 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; + +-- type Input_Object_Record is +-- end record; +-- Read (Input_Object_Record); +-- Write (Input_Object_Record); +-- Close (Input_Object_Record); +-- +-- type Input_Object_Class_Pointer is access all Input_Object_Record'Class; +-- +-- type Input_Record is record +-- Pos: Standard.Natural; +-- Last: Standard.Natural; +-- Buffer: Object_String (1 .. 1024); +-- Handle: Input_Object_Class_Pointer; +-- end record; +-- function Get_Character return Object_Character is +-- begin +-- if Interp.Input.Pos >= Interp.Input.Last then +-- Read (Interp.Input.Handle, Interp.Input.Buffer, Interp.Input.Last); +-- Interp.Input.Pos := Interp.Input.Buffer'First - 1; +-- end if; +-- +-- Interp.Input.Pos := Interp.Input.Pos + 1; +-- return Interp.Input.Buffer(Interp.Input.Pos); +-- end Get_Character; + + begin + null; + + --if Interp.Input.Handle = null then + -- Interp.Input.Handle := Interp.Tio (""); + -- Interp.Input.Pos := 0; + -- Interp.Input.Last := 0; + --end if; + + -- In Interp.Close() + -- if Interp.Input.Handle /= null then + -- Close (Interp.Input.Handle); + --end if; + end Read_Object; + begin -- Stack frames looks like this upon initialization @@ -2373,6 +2559,11 @@ Print (Interp, Operand); loop case Get_Frame_Opcode(Interp.Stack) is + when Opcode_Exit => + Result := Get_Frame_Return (Interp.Stack); + Pop_Frame; + exit; + when Opcode_Evaluate_Object => Evaluate_Object; @@ -2388,10 +2579,8 @@ Print (Interp, Operand); when Opcode_Apply => Apply; - when Opcode_Exit => - Result := Get_Frame_Return (Interp.Stack); - Pop_Frame; - exit; + when Opcode_Read_Object => + Read_Object; end case; end loop; @@ -2405,6 +2594,13 @@ Print (Interp, Operand); -- TODO: restore envirronemtn frame??? end Evaluate; + procedure Run_Loop (Interp: in out Interpreter_Record; + Result: out Object_Pointer) is + -- standard read-eval-print loop + begin + null; + end Run_Loop; + ----------------------------------------------------------------------------- function h2scm_open return Interpreter_Pointer; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index b611cb0..3c74ee9 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -6,23 +6,62 @@ -- # # # # # # # # # # # -- # # # # # # # # # # # # # -- ##### #### # # ###### # # ###### # # ####### +-- +-- Literal +-- Number: 1, 10 +-- String: "hello" +-- +-- Environment +-- The environment holds the key/value pairs. +-- +-- Procedure +-- Some builtin-procedure objects are registered to the top-level environment +-- upon start-up. You can break the mapping between a name and a procedure +-- as it's in the normal environment. +-- +-- Syntax Object +-- Some syntax objects are registered upon start-up. They are handled +-- very specially when the list containing one of them as the first argument +-- is evaluated. +-- +-- Evaluation Rule +-- A literal object evaluates to itself. A Symbol object evaluates to +-- a value found in the environment. List evaluation is slightly more +-- complex. Each element of a list is evluated using the standard evaluation +-- rule. The first argument acts as a function and the rest of the arguments +-- are applied to the function. An element must evaluate to a closure to be +-- a function. The syntax object bypasses the normal evaluation rule and is +-- evaluated according to the object-specific rule. +-- --------------------------------------------------------------------- with System; with System.Storage_Pools; - with Ada.Unchecked_Conversion; -- TODO: delete these after debugging with ada.text_io; with ada.wide_text_io; with ada.integer_text_io; with ada.long_integer_text_io; ---with system.address_image; -- TODO: delete above after debugging package H2.Scheme is + type Interpreter_Record is limited private; + type Interpreter_Pointer is access all Interpreter_Record; + + -- ----------------------------------------------------------------------------- + -- While I could define Heap_Element and Heap_Size to be + -- the subtype of Object_Byte and Object_Size each, they are not + -- logically the same thing. + -- subtype Storage_Element is Object_Byte; + -- subtype Storage_Count is Object_Size; + type Heap_Element is mod 2 ** System.Storage_Unit; + type Heap_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1; + + -- ----------------------------------------------------------------------- + -- An object pointer takes up as many bytes as a system word. Object_Pointer_Bits: constant := System.Word_Size; Object_Pointer_Bytes: constant := Object_Pointer_Bits / System.Storage_Unit; @@ -173,8 +212,8 @@ package H2.Scheme is -- Object payload: -- I assume that the smallest payload is able to hold an -- object pointer by specifying the alignement attribute - -- to Object_Pointer_Bytes. this implementation will break - -- severely if this assumption is not correct. + -- to Object_Pointer_Bytes and checking the minimum allocation + -- size in Allocate_Bytes_In_Heap(). case Kind is when Moved_Object => New_Pointer: Object_Pointer := null; @@ -248,26 +287,72 @@ package H2.Scheme is pragma Inline (Pointer_To_Byte); -- ----------------------------------------------------------------------------- - -- While I could define Heap_Element and Heap_Size to be - -- the subtype of Object_Byte and Object_Size each, they are not - -- logically the same thing. - -- subtype Storage_Element is Object_Byte; - -- subtype Storage_Count is Object_Size; - type Heap_Element is mod 2 ** System.Storage_Unit; - type Heap_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1; + + + type Stream_Record is abstract tagged limited null record; + + procedure Open (Stream: in out Stream_Record) is abstract; + + procedure Close (Stream: in out Stream_Record) is abstract; + + procedure Read (Stream: in out Stream_Record; + Data: out Object_String; + Last: out Standard.Natural) is abstract; + + procedure Write (Stream: in out Stream_Record; + Data: out Object_String; + Last: out Standard.Natural) is abstract; + + type Stream_Pointer is access all Stream_Record'Class; + + type Stream_Allocator is access + procedure (Interp: in out Interpreter_Record; + Name: access Object_String; + Result: out Stream_Pointer); + + type Stream_Deallocator is access + procedure (Interp: in out Interpreter_Record; + Source: in out Stream_Pointer); + + + type IO_Flags is mod 2 ** 4; + IO_End_Reached: constant IO_Flags := IO_Flags'(2#0001#); + IO_Error_Occurred: constant IO_Flags := IO_Flags'(2#0001#); + + type IO_Record; + type IO_Pointer is access all IO_Record; + + type IO_Record is record + --type IO_Record is limited record + Stream: Stream_Pointer := null; + --Data: Object_String(1..2048) := (others => ' '); + Data: Object_String(1..5) := (others => ' '); + Last: Standard.Natural := 0; + Pos: Standard.Natural := 0; + Flags: IO_Flags := 0; -- EOF, ERROR + Next: IO_Pointer; + end record; + + + -- ----------------------------------------------------------------------------- type Trait_Mask is mod 2 ** System.Word_Size; No_Garbage_Collection: constant Trait_Mask := 2#0000_0000_0000_0001#; No_Optimization: constant Trait_Mask := 2#0000_0000_0000_0010#; - type Option_Kind is (Trait_Option); + type Option_Kind is (Trait_Option, Stream_Option); type Option_Record (Kind: Option_Kind) is record case Kind is when Trait_Option => Trait_Bits: Trait_Mask := 0; + + when Stream_Option => + Allocate: Stream_Allocator := null; + Deallocate: Stream_Deallocator := null; end case; end record; + -- ----------------------------------------------------------------------------- -- The nil/true/false object are represented by special pointer values. @@ -297,26 +382,6 @@ 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; @@ -325,6 +390,21 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec procedure Close (Interp: in out Interpreter_Record); + function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer; + + procedure Set_Option (Interp: in out Interpreter_Record; + Option: in Option_Record); + + procedure Get_Option (Interp: in out Interpreter_Record; + Option: in out Option_Record); + + procedure Set_Input_Stream (Interp: in out Interpreter_Record; + Stream: in out Stream_Record'Class); + + -- Source must be open for Read() to work. + procedure Read (Interp: in out Interpreter_Record; + Result: out Object_Pointer); + procedure Evaluate (Interp: in out Interpreter_Record; Source: in Object_Pointer; Result: out Object_Pointer); @@ -332,12 +412,8 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec procedure Print (Interp: in out Interpreter_Record; Source: in Object_Pointer); - procedure Set_Option (Interp: in out Interpreter_Record; - Option: in Option_Record); - - procedure Get_Option (Interp: in out Interpreter_Record; - Option: in out Option_Record); - + procedure Run_Loop (Interp: in out Interpreter_Record; + Result: out Object_Pointer); -- ----------------------------------------------------------------------------- @@ -361,12 +437,13 @@ private Next: Object_Pointer := Nil_Pointer; 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; + --Self: Interpreter_Pointer := null; + Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer Storage_Pool: Storage_Pool_Pointer := null; Trait: Option_Record(Trait_Option); + Stream: Option_Record(Stream_Option); Heap: Heap_Pointer_Array := (others => null); Current_Heap: Heap_Number := Heap_Number'First; @@ -380,9 +457,9 @@ private R: Register_Record; - Line: Object_String(1..1024); - Line_Last: Standard.Natural; - Line_Pos: Standard.Natural; + -- TODO: Buffer_Record needs to be stacked to handle "load". + Input: aliased IO_Record; + IO: IO_Pointer := null; end record; end H2.Scheme; diff --git a/lib/h2.ads b/lib/h2.ads index cc3ffdf..38b714d 100644 --- a/lib/h2.ads +++ b/lib/h2.ads @@ -2,7 +2,7 @@ with System.Storage_Pools; package H2 is - subtype Character is Standard.Wide_Character; + --subtype Character is Standard.Wide_Character; type Storage_Pool_Pointer is access all System.Storage_Pools.Root_Storage_Pool'Class; diff --git a/lib/lib.gpr.in b/lib/lib.gpr.in index c839676..e78063d 100644 --- a/lib/lib.gpr.in +++ b/lib/lib.gpr.in @@ -22,7 +22,7 @@ project Lib is package Compiler is for Default_Switches ("Ada") use ( - "-gnata", "-gnato", "-gnatN", "-gnatwl" + "-gnata", "-gnato", "-gnatN", "-gnatwl", "-gnat95" ); end Compiler;