added experimental stream handling code
This commit is contained in:
parent
dcf676476f
commit
eac1df647a
@ -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 ("-------------------------------------------");
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
|
||||
87
cmd/stream.adb
Normal file
87
cmd/stream.adb
Normal file
@ -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;
|
||||
48
cmd/stream.ads
Normal file
48
cmd/stream.ads
Normal file
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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,28 +1443,115 @@ 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
|
||||
@ -1439,7 +1559,7 @@ Put_String (To_Thin_String_Pointer (Result));
|
||||
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;
|
||||
|
||||
@ -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,12 +390,7 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec
|
||||
|
||||
procedure Close (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);
|
||||
function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer;
|
||||
|
||||
procedure Set_Option (Interp: in out Interpreter_Record;
|
||||
Option: in Option_Record);
|
||||
@ -338,6 +398,22 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec
|
||||
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);
|
||||
|
||||
procedure Print (Interp: in out Interpreter_Record;
|
||||
Source: in Object_Pointer);
|
||||
|
||||
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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user