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

added experimental stream handling code

Browse Source
This commit is contained in:
hyung-hwan 2013-12-28 16:52:31 +00:00
parent dcf676476f
commit eac1df647a
10 changed files with 575 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
cmd/scheme.adb
View File

@ -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 ("-------------------------------------------");

8
cmd/scheme.gpr.in
View File

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

48
lib/h2-pool.adb
View File

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

9
lib/h2-pool.ads
View File

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

260
lib/h2-scheme.adb
View File

@ -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 =>
Interp.Trait := Option;
when Stream_Option =>
Interp.Stream := Option;
end case;
end Set_Option;
@ -1412,26 +1445,113 @@ Put_String (To_Thin_String_Pointer (Result));
case Option.Kind is
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;
end if;
Text_IO.Get_Line (Interp.Line, Interp.Line_Last);
Interp.Line_Pos := Interp.Line'First - 1;
-- 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;
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;

163
lib/h2-scheme.ads
View File

@ -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
lib/h2.ads
View File

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

2
lib/lib.gpr.in
View File

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