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

added some input procedures

Browse Source
This commit is contained in:
hyung-hwan 2014-01-01 14:07:03 +00:00
parent eac1df647a
commit dd9a5a9a2e
6 changed files with 328 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
cmd/scheme.adb
View File

@ -15,57 +15,34 @@ procedure scheme is
O: S.Object_Pointer; O: S.Object_Pointer;
--String: aliased S.Object_String := "(car '(1 2 3))"; --String: aliased S.Object_String := "(car '(1 2 3))";
String: aliased S.Object_String := "((lambda (x y) (+ x y)) 9 7)"; String: aliased constant 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 (String'Unchecked_Access);
--String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0); --String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0);
File_Name: aliased S.Object_String := "test.adb"; --File_Name: aliased S.Object_String := "test.adb";
File_Name: aliased constant S.Object_String := "test.adb";
--File_Stream: Stream.File_Stream_Record (File_Name'Unchecked_Access); --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 := (Name => File_Name'Unchecked_Access);
File_Stream: Stream.File_Stream_Record; 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 begin
Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Pointer_Bytes)); Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Pointer_Bytes));
S.Open (SI, 2_000_000, Pool'Unchecked_Access); S.Open (SI, 2_000_000, Pool'Unchecked_Access);
--S.Open (SI, null); --S.Open (SI, null);
File_Stream.Name := File_Name'Unchecked_Access; -- Specify the named stream handler
S.Set_Input_Stream (SI, File_Stream); -- specify main input stream S.Set_Option (SI, (S.Stream_Option,
--S.Set_Output_Stream (SI, Stream); -- specify main output stream. Stream.Allocate_Stream'Access,
Stream.Deallocate_Stream'Access)
);
File_Stream.Name := File_Name'Unchecked_Access;
S.Set_Input_Stream (SI, File_Stream); -- specify main input stream
--S.Set_Input_Stream (SI, String_Stream);
--S.Set_Output_Stream (SI, Stream); -- specify main output stream.
S.Read (SI, I); S.Read (SI, I);
S.Make_Test_Object (SI, I); S.Make_Test_Object (SI, I);
@ -107,5 +84,4 @@ S.Print (SI, O);
Ada.Text_IO.Put_Line ("BYE..."); Ada.Text_IO.Put_Line ("BYE...");
end scheme; end scheme;

45
cmd/stream.adb
View File

@ -1,3 +1,5 @@
with H2.Pool;
with Ada.Characters.Conversions;
package body Stream is package body Stream is
@ -5,13 +7,13 @@ package body Stream is
procedure Open (Stream: in out String_Input_Stream_Record) is procedure Open (Stream: in out String_Input_Stream_Record) is
begin begin
Ada.Text_IO.Put_Line ("OPEN STRING STREAM"); Ada.Wide_Text_IO.Put_Line ("****** OPEN STRING STREAM ******");
Stream.Pos := 0; Stream.Pos := 0;
end Open; end Open;
procedure Close (Stream: in out String_Input_Stream_Record) is procedure Close (Stream: in out String_Input_Stream_Record) is
begin begin
Ada.Text_IO.Put_Line ("CLOSE STRING STREAM"); Ada.Wide_Text_IO.Put_Line ("****** CLOSE STRING STREAM ******");
Stream.Pos := Stream.Str'Last; Stream.Pos := Stream.Str'Last;
end Close; end Close;
@ -47,14 +49,14 @@ Ada.Text_IO.Put_Line ("CLOSE STRING STREAM");
procedure Open (Stream: in out File_Stream_Record) is procedure Open (Stream: in out File_Stream_Record) is
begin begin
Ada.Text_IO.Put_Line ("OPEN File STREAM"); Ada.Wide_Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<<");
Ada.Text_IO.Open (Stream.Handle, Ada.Text_IO.In_File, Stream.Name.all); Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Stream.Name.all));
end Open; end Open;
procedure Close (Stream: in out File_Stream_Record) is procedure Close (Stream: in out File_Stream_Record) is
begin begin
Ada.Text_IO.Put_Line ("CLOSE File STREAM"); Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<<");
Ada.Text_IO.Close (Stream.Handle); Ada.Wide_Text_IO.Close (Stream.Handle);
end Close; end Close;
procedure Read (Stream: in out File_Stream_Record; procedure Read (Stream: in out File_Stream_Record;
@ -63,9 +65,9 @@ Ada.Text_IO.Put_Line ("CLOSE File STREAM");
begin begin
for I in Data'First .. Data'Last loop for I in Data'First .. Data'Last loop
begin begin
Ada.Text_IO.Get_Immediate (Stream.Handle, Data(I)); Ada.Wide_Text_IO.Get_Immediate (Stream.Handle, Data(I));
exception exception
when Ada.Text_IO.End_Error => when Ada.Wide_Text_IO.End_Error =>
Last := I - 1; Last := I - 1;
return; return;
-- other exceptions must be just raised to indicate errors -- other exceptions must be just raised to indicate errors
@ -84,4 +86,31 @@ Ada.Text_IO.Put_Line ("CLOSE File STREAM");
------------------------------------------------------------------ ------------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
Name: in S.Constant_Object_String_Pointer;
Result: 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 := 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;
end Stream; end Stream;

26
cmd/stream.ads
View File

@ -1,12 +1,13 @@
with H2.Scheme; with H2.Scheme;
with Ada.Text_IO; with Ada.Wide_Text_IO;
package Stream is package Stream is
package S renames H2.Scheme; package S renames H2.Scheme;
------------------------------------------------------------ ------------------------------------------------------------
type Object_String_Pointer is access all S.Object_String; --type Object_String_Pointer is access all S.Object_String;
type Object_String_Pointer is access constant S.Object_String;
type String_Input_Stream_Record(Str: Object_String_Pointer) is new S.Stream_Record with record type String_Input_Stream_Record(Str: Object_String_Pointer) is new S.Stream_Record with record
Pos: Standard.Natural := 0; Pos: Standard.Natural := 0;
end record; end record;
@ -27,14 +28,15 @@ package Stream is
------------------------------------------------------------ ------------------------------------------------------------
--type File_Stream_Record(Name: Object_String_Pointer) is new S.Stream_Record with record --type File_Stream_Record(Name: Object_String_Pointer) is new S.Stream_Record with record
-- Handle: Ada.Text_IO.File_Type; -- Handle: H2.Text_IO.File_Type;
--end record; --end record;
type File_Stream_Record is new S.Stream_Record with record type File_Stream_Record is new S.Stream_Record with record
Name: Object_String_Pointer; Name: S.Constant_Object_String_Pointer;
Handle: Ada.Text_IO.File_Type; Handle: Ada.Wide_Text_IO.File_Type;
end record; end record;
procedure Open (Stream: in out File_Stream_Record); procedure Open (Stream: in out File_Stream_Record);
procedure Close (Stream: in out File_Stream_Record); procedure Close (Stream: in out File_Stream_Record);
procedure Read (Stream: in out File_Stream_Record; procedure Read (Stream: in out File_Stream_Record;
@ -44,5 +46,19 @@ package Stream is
Data: out S.Object_String; Data: out S.Object_String;
Last: out Standard.Natural); Last: out Standard.Natural);
------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
Name: in S.Constant_Object_String_Pointer;
Result: out S.Stream_Pointer);
procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;
Source: in out S.Stream_Pointer);
--private
-- type File_Stream_Record is new S.Stream_Record with record
-- Name: S.Constant_Object_String_Pointer;
-- Handle: Ada.Wide_Text_IO.File_Type;
-- end record;
end Stream; end Stream;

389
lib/h2-scheme.adb
View File

@ -5,8 +5,24 @@ with System.Address_To_Access_Conversions;
with Ada.Unchecked_Deallocation; -- for h2scm c interface. TOOD: move it to a separate file with Ada.Unchecked_Deallocation; -- for h2scm c interface. TOOD: move it to a separate file
with Interfaces.C; with Interfaces.C;
-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx
with Ada.Characters.Handling;
with Ada.Characters.Conversions;
with Ada.Wide_Characters.Handling;
-- TODO: delete these after debugging
with ada.text_io;
with ada.wide_text_io;
-- TODO: delete above after debugging
-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx
package body H2.Scheme is package body H2.Scheme is
function To_Object_String (Item: in Standard.String) return Object_String renames Ada.Characters.Conversions.To_Wide_String;
package Text_IO renames ada.Wide_Text_IO;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- EXCEPTIONS -- EXCEPTIONS
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@ -15,6 +31,7 @@ package body H2.Scheme is
Syntax_Error: exception; Syntax_Error: exception;
Evaluation_Error: exception; Evaluation_Error: exception;
Internal_Error: exception; Internal_Error: exception;
IO_Error: exception;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- INTERNALLY-USED TYPES -- INTERNALLY-USED TYPES
@ -158,7 +175,7 @@ package body H2.Scheme is
-- or short. In reality, the last Unicode code point assigned is far -- or short. In reality, the last Unicode code point assigned is far
-- less than #16#7FFFFFFF# as of this writing. So I should not be -- less than #16#7FFFFFFF# as of this writing. So I should not be
-- worried about it for the time being. -- worried about it for the time being.
Word := Object_Character'Pos (Char); Word := Object_Character'Pos(Char);
Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Character); Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Character);
--return Object_Word_To_Object_Pointer (Word); --return Object_Word_To_Object_Pointer (Word);
return Pointer; return Pointer;
@ -199,7 +216,7 @@ package body H2.Scheme is
function Pointer_To_Character (Pointer: in Object_Pointer) return Object_Character is function Pointer_To_Character (Pointer: in Object_Pointer) return Object_Character is
Word: Object_Word := Pointer_To_Word (Pointer); Word: Object_Word := Pointer_To_Word (Pointer);
begin begin
return Object_Character'Val (Word / (2 ** Object_Pointer_Type_Bits)); return Object_Character'Val(Word / (2 ** Object_Pointer_Type_Bits));
end Pointer_To_Character; end Pointer_To_Character;
function Pointer_To_Byte (Pointer: in Object_Pointer) return Object_Byte is function Pointer_To_Byte (Pointer: in Object_Pointer) return Object_Byte is
@ -269,7 +286,7 @@ package body H2.Scheme is
end; end;
end Copy_String; end Copy_String;
function To_String (Source: in Object_Character_Array) return Object_String is function Character_Array_To_String (Source: in Object_Character_Array) return Object_String is
begin begin
-- ObjectAda complains that the member of Object_String is not -- ObjectAda complains that the member of Object_String is not
-- aliased because Object_Character_Array is an array of aliased -- aliased because Object_Character_Array is an array of aliased
@ -283,7 +300,7 @@ package body H2.Scheme is
return To_Character_Array (Source (Source'First .. Source'Last - 1)); return To_Character_Array (Source (Source'First .. Source'Last - 1));
--return String_Array (Source (Source'First .. Source'Last - 1)); --return String_Array (Source (Source'First .. Source'Last - 1));
end; end;
end To_String; end Character_Array_To_String;
type Thin_String is new Object_String (Standard.Positive'Range); type Thin_String is new Object_String (Standard.Positive'Range);
type Thin_String_Pointer is access all Thin_String; type Thin_String_Pointer is access all Thin_String;
@ -329,20 +346,22 @@ package body H2.Scheme is
begin begin
Ptr_Type := Get_Pointer_Type(Source); Ptr_Type := Get_Pointer_Type(Source);
if Ptr_Type = Object_Pointer_Type_Character then if Ptr_Type = Object_Pointer_Type_Character then
Text_IO.Put_Line (Msg & Object_Character'Image(Pointer_To_Character(Source))); Text_IO.Put_Line (Msg & To_Object_String(Object_Character'Image(Pointer_To_Character(Source))));
elsif Ptr_Type = Object_Pointer_Type_Integer then elsif Ptr_Type = Object_Pointer_Type_Integer then
Text_IO.Put_Line (Msg & Object_Integer'Image(Pointer_To_Integer(Source))); Text_IO.Put_Line (Msg & To_Object_String(Object_Integer'Image(Pointer_To_Integer(Source))));
elsif Is_Special_Pointer (Source) then elsif Is_Special_Pointer (Source) then
Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W)); Text_IO.Put_Line (Msg & " at " & To_Object_String(Object_Word'Image(W)));
elsif Source.Kind = Character_Object then elsif Source.Kind = Character_Object then
Text_IO.Put (Msg & " at " & Object_Word'Image(W) & " at " & Object_Kind'Image(Source.Kind) & " size " & Object_Size'Image(Source.Size) & " - "); Text_IO.Put (Msg & " at " & To_Object_String(Object_Word'Image(W)) &
" at " & To_Object_String(Object_Kind'Image(Source.Kind)) &
" size " & To_Object_String(Object_Size'Image(Source.Size)) & " - ");
if Source.Kind = Moved_Object then if Source.Kind = Moved_Object then
Text_IO.Put_Line (To_String (Get_New_Location(Source).Character_Slot)); Text_IO.Put_Line (Character_Array_To_String (Get_New_Location(Source).Character_Slot));
else else
Text_IO.Put_Line (To_String (Source.Character_Slot)); Text_IO.Put_Line (Character_Array_To_String (Source.Character_Slot));
end if; end if;
else else
Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W) & " at " & Object_Kind'Image(Source.Kind)); Text_IO.Put_Line (Msg & " at " & To_Object_String(Object_Word'Image(W)) & " at " & To_Object_String(Object_Kind'Image(Source.Kind)));
end if; end if;
end Print_Object_Pointer; end Print_Object_Pointer;
@ -541,8 +560,8 @@ Print_Object_Pointer ("Moving REALLY ...", Object);
-- if the object is marked with FLAG_MOVED; -- if the object is marked with FLAG_MOVED;
Set_New_Location (Object, Ptr); Set_New_Location (Object, Ptr);
Text_IO.Put_Line (Object_Word'Image(Pointer_To_Word(Object)) & Object_Word'Image(Pointer_To_Word(New_Object))); Ada.Text_IO.Put_Line (Object_Word'Image(Pointer_To_Word(Object)) & Object_Word'Image(Pointer_To_Word(New_Object)));
Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Object.Kind) & " New Size " & Object_Size'Image(Object.Size) & " New Loc: " & Object_Word'Image(Pointer_To_Word(Object.New_Pointer))); Ada.Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Object.Kind) & " New Size " & Object_Size'Image(Object.Size) & " New Loc: " & Object_Word'Image(Pointer_To_Word(Object.New_Pointer)));
-- Return the new object -- Return the new object
return New_Object; return New_Object;
end; end;
@ -614,7 +633,7 @@ Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Object.Kind) & " New S
-- A non-syntax symbol has not been moved. -- A non-syntax symbol has not been moved.
-- Unlink the cons cell from the symbol table. -- Unlink the cons cell from the symbol table.
Text_IO.Put_Line ("COMPACT_SYMBOL_TABLE Unlinking " & To_String (Car.Character_Slot)); Text_IO.Put_Line ("COMPACT_SYMBOL_TABLE Unlinking " & Character_Array_To_String (Car.Character_Slot));
if Pred = Nil_Pointer then if Pred = Nil_Pointer then
Interp.Symbol_Table := Cdr; Interp.Symbol_Table := Cdr;
else else
@ -1296,6 +1315,70 @@ Put_String (To_Thin_String_Pointer (Result));
end loop; end loop;
end Deinitialize_Heap; end Deinitialize_Heap;
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 Start_Named_Input_Stream (Interp: in out Interpreter_Record;
Name: in Constant_Object_String_Pointer) is
package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool);
IO: IO_Pointer := null;
Stream: Stream_Pointer := null;
begin
begin
IO := IO_Pool.Allocate;
Interp.Stream.Allocate (Interp, Name, Stream);
exception
when others =>
if IO /= null then
if Stream /= null then
Interp.Stream.Deallocate (Interp, Stream);
end if;
IO_Pool.Deallocate (IO);
end if;
raise;
end;
--IO.Stream := Stream;
--IO.Pos := IO.Data'First - 1;
--IO.Last := IO.Data'First - 1;
--IO.Flags := 0;
--IO.Next := Interp.Input;
--Interp.Input := IO;
IO.all := IO_Record'(
Stream => Stream,
Data => (others => ' '),
Pos | Last => IO.Data'First - 1,
Flags => 0,
Next => Interp.Input,
Iochar => IO_Character_Record'(End_Character, Object_Character'First)
);
Interp.Input := IO;
end Start_Named_Input_Stream;
procedure Stop_Named_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.Input /= Interp.Base_Input'Unchecked_Access);
IO := Interp.Input;
Interp.Input := IO.Next;
pragma Assert (IO.Stream /= null);
Close_Stream (IO.Stream);
Interp.Stream.Deallocate (Interp, IO.Stream);
IO_Pool.Deallocate (IO);
end Stop_Named_Input_Stream;
-----------------------------------------------------------------------------
procedure Open (Interp: in out Interpreter_Record; procedure Open (Interp: in out Interpreter_Record;
Initial_Heap_Size: in Heap_Size; Initial_Heap_Size: in Heap_Size;
Storage_Pool: in Storage_Pool_Pointer := null) is Storage_Pool: in Storage_Pool_Pointer := null) is
@ -1382,8 +1465,8 @@ Put_String (To_Thin_String_Pointer (Result));
Interp.Root_Table := Nil_Pointer; Interp.Root_Table := Nil_Pointer;
Interp.Symbol_Table := Nil_Pointer; Interp.Symbol_Table := Nil_Pointer;
Interp.Input.Stream := null; Interp.Base_Input.Stream := null;
Interp.IO := Interp.Input'Unchecked_Access; Interp.Input := Interp.Base_Input'Unchecked_Access;
-- TODO: disallow garbage collecion during initialization. -- TODO: disallow garbage collecion during initialization.
Text_IO.Put_Line ("1111111111"); Text_IO.Put_Line ("1111111111");
@ -1395,31 +1478,25 @@ Text_IO.Put_Line ("1111111111");
Make_Procedure_Objects; Make_Procedure_Objects;
Text_IO.Put_Line ("99999"); Text_IO.Put_Line ("99999");
Text_IO.Put_Line (To_Object_String(IO_Character_Record'Size'Img));
Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Elements'Img));
exception exception
when others => when others =>
Deinitialize_Heap (Interp); Deinitialize_Heap (Interp);
end Open; 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 procedure Close (Interp: in out Interpreter_Record) is
begin begin
Close_All_Streams (Interp); -- Destroy all unstacked named input streams
while Interp.Input /= Interp.Base_Input'Unchecked_Access loop
Stop_Named_Input_Stream (Interp);
end loop;
if Interp.Base_Input.Stream /= null then
-- Close the main input stream.
Close_Stream (Interp.Base_Input.Stream);
end if;
Deinitialize_Heap (Interp); Deinitialize_Heap (Interp);
end Close; end Close;
@ -1458,21 +1535,18 @@ Text_IO.Put_Line ("99999");
-- if Open raised an exception, it wouldn't reach here. -- if Open raised an exception, it wouldn't reach here.
-- so the existing stream still remains intact. -- so the existing stream still remains intact.
if Interp.Input.Stream /= null then if Interp.Base_Input.Stream /= null then
Close_Stream (Interp.Input.Stream); Close_Stream (Interp.Base_Input.Stream);
end if; end if;
--Interp.Input := IO_Record'( Interp.Base_Input := IO_Record'(
-- Stream => Stream'Unchecked_Access, Stream => Stream'Unchecked_Access,
-- Data => (others => ' '), Data => (others => Object_Character'First),
-- Pos => Interp.Input.Data'First - 1, Pos | Last => Interp.Base_Input.Data'First - 1,
-- Last => Interp.Input.Data'First - 1, Flags => 0,
-- Flags => 0 Next => null,
--); Iochar => IO_Character_Record'(End_Character, Object_Character'First)
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; end Set_Input_Stream;
--procedure Set_Output_Stream (Interp: in out Interpreter_Record; --procedure Set_Output_Stream (Interp: in out Interpreter_Record;
@ -1481,60 +1555,19 @@ Text_IO.Put_Line ("99999");
-- --
--end Set_Output_Stream; --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; procedure Read (Interp: in out Interpreter_Record;
Result: out Object_Pointer) is Result: out Object_Pointer) is
End_Error: exception; procedure Fetch_Character is
function Get_Character return Object_Character is
begin begin
-- TODO: calculate Interp.Input.Row, Interp.Input.Column -- TODO: calculate Interp.Input.Row, Interp.Input.Column
if Interp.Input.Pos >= Interp.Input.Last then if Interp.Input.Pos >= Interp.Input.Last then
if Interp.Input.Flags /= 0 then if Interp.Input.Flags /= 0 then
-- an error has occurred previously. -- An error has occurred or EOF has been reached previously.
raise End_Error; -- Note calling this procedure after EOF results in an error.
Interp.Input.Iochar := (Error_Character, Object_Character'First);
--return;
raise IO_Error;
end if; end if;
Interp.Input.Pos := Interp.Input.Data'First - 1; Interp.Input.Pos := Interp.Input.Data'First - 1;
@ -1542,27 +1575,80 @@ Text_IO.Put_Line ("99999");
Read (Interp.Input.Stream.all, Interp.Input.Data, Interp.Input.Last); Read (Interp.Input.Stream.all, Interp.Input.Data, Interp.Input.Last);
exception exception
when others => when others =>
-- The callee can raise an exception upon errors.
-- If an exception is raised, data read into the buffer
-- is also ignored.
Interp.Input.Flags := Interp.Input.Flags and IO_Error_Occurred; Interp.Input.Flags := Interp.Input.Flags and IO_Error_Occurred;
raise End_Error; -- TODO: change the exception name Interp.Input.Iochar := (Error_Character, Object_Character'First);
--return;
raise IO_Error;
end; end;
if Interp.Input.Last < Interp.Input.Data'First then if Interp.Input.Last < Interp.Input.Data'First then
-- The callee must read 0 bytes on EOF
Interp.Input.Flags := Interp.Input.Flags and IO_End_Reached; Interp.Input.Flags := Interp.Input.Flags and IO_End_Reached;
raise End_Error; Interp.Input.Iochar := (End_Character, Object_Character'First);
return;
end if; end if;
end if; end if;
Interp.Input.Pos := Interp.Input.Pos + 1; Interp.Input.Pos := Interp.Input.Pos + 1;
return Interp.Input.Data(Interp.Input.Pos); Interp.Input.Iochar := (Normal_Character, Interp.Input.Data(Interp.Input.Pos));
end Get_Character; end Fetch_Character;
procedure Skip_Space is procedure Skip_Spaces is
C: IO_Character_Record renames Interp.Input.Iochar;
begin begin
null; loop
end Skip_Space; exit when C.Kind /= Normal_Character;
--function Get_Token return Token_Type is -- normal character
--begin case C.Value is
-- null; when ' ' |
--end Get_Token; Object_Character'Val(Standard.Character'Pos(Standard.ASCII.HT)) |
Object_Character'Val(Standard.Character'Pos(Standard.ASCII.VT)) |
Object_Character'Val(Standard.Character'Pos(Standard.ASCII.CR)) |
Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)) |
Object_Character'Val(Standard.Character'Pos(Standard.ASCII.FF)) =>
-- white space
Fetch_Character;
when ';' =>
-- comment. consume until EOL
loop
Fetch_Character;
exit when C.Kind = Normal_Character and then
C.Value = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF));
end loop;
when others =>
exit;
end case;
end loop;
end Skip_Spaces;
procedure Fetch_Token is
C: IO_Character_Record renames Interp.Input.Iochar;
begin
Skip_Spaces;
if C.Kind /= Normal_Character then
Interp.Token.Kind := End_Token;
return;
end if;
case C.Value is
when '(' =>
Interp.Token := (Left_Parenthesis_Token, "(");
when ')' =>
Interp.Token := (Left_Parenthesis_Token, ")");
when ''' =>
Interp.Token := (Single_Quote_Token, ")");
when others =>
null;
end case;
end Fetch_Token;
procedure Read_Atom (Atom: out Object_Pointer) is procedure Read_Atom (Atom: out Object_Pointer) is
begin begin
@ -1573,7 +1659,7 @@ Text_IO.Put_Line ("99999");
Opcode: Object_Integer; Opcode: Object_Integer;
Operand: Object_Pointer; Operand: Object_Pointer;
C: Object_Character; C: IO_Character_Record renames Interp.Input.Iochar;
begin begin
--Opcode := 1; --Opcode := 1;
--loop --loop
@ -1581,14 +1667,30 @@ Text_IO.Put_Line ("99999");
-- when 1 => -- when 1 =>
--end loop; --end loop;
loop loop
C := Get_Character; begin
Text_IO.Put (C); Fetch_Character;
end loop;
exception exception
when End_Error => when others =>
TEXT_IO.New_Line;
Text_IO.Put_Line ("INPUT ERROR...");
exit;
end;
case C.Kind is
when Normal_Character =>
Text_IO.Put (C.Value);
when End_Character =>
TEXT_IO.New_Line; TEXT_IO.New_Line;
Text_IO.Put_Line ("END OF INPUT..."); Text_IO.Put_Line ("END OF INPUT...");
exit;
when Error_Character =>
TEXT_IO.New_Line;
Text_IO.Put_Line ("INPUT ERROR...");
exit;
end case;
end loop;
end Read; end Read;
procedure Print (Interp: in out Interpreter_Record; procedure Print (Interp: in out Interpreter_Record;
@ -1618,11 +1720,11 @@ Text_IO.Put_Line ("99999");
raise Internal_Error; raise Internal_Error;
when Symbol_Object => when Symbol_Object =>
Text_IO.Put (To_String (Atom.Character_Slot)); Text_IO.Put (Character_Array_To_String (Atom.Character_Slot));
when String_Object => when String_Object =>
Text_IO.Put (""""); Text_IO.Put ("""");
Text_IO.Put (To_String (Atom.Character_Slot)); Text_IO.Put (Character_Array_To_String (Atom.Character_Slot));
Text_IO.Put (""""); Text_IO.Put ("""");
when Closure_Object => when Closure_Object =>
@ -1639,7 +1741,7 @@ Text_IO.Put_Line ("99999");
when Others => when Others =>
if Atom.Kind = Character_Object then if Atom.Kind = Character_Object then
Text_IO.Put (To_String (Atom.Character_Slot)); Text_IO.Put (Character_Array_To_String (Atom.Character_Slot));
else else
Text_IO.Put ("#NOIMPL#"); Text_IO.Put ("#NOIMPL#");
end if; end if;
@ -1650,19 +1752,19 @@ Text_IO.Put_Line ("99999");
procedure Print_Integer is procedure Print_Integer is
X: constant Object_Integer := Pointer_To_Integer (Atom); X: constant Object_Integer := Pointer_To_Integer (Atom);
begin begin
Text_IO.Put (Object_Integer'Image (X)); Text_IO.Put (To_Object_String(Object_Integer'Image(X)));
end Print_Integer; end Print_Integer;
procedure Print_Character is procedure Print_Character is
X: constant Object_Character := Pointer_To_Character (Atom); X: constant Object_Character := Pointer_To_Character (Atom);
begin begin
Text_IO.Put (Object_Character'Image (X)); Text_IO.Put (To_OBject_String(Object_Character'Image(X)));
end Print_Character; end Print_Character;
procedure Print_Byte is procedure Print_Byte is
X: constant Object_Byte := Pointer_To_Byte (Atom); X: constant Object_Byte := Pointer_To_Byte (Atom);
begin begin
Text_IO.Put (Object_Byte'Image (X)); Text_IO.Put (To_Object_String(Object_Byte'Image(X)));
end Print_Byte; end Print_Byte;
begin begin
@ -1934,7 +2036,7 @@ begin
); );
L := Make_Cons ( L := Make_Cons (
Interp.Self, Interp.Self,
Make_Symbol (Interp.Self, "lambda"), Make_Symbol (Interp.Self, Object_String'("lambda")),
Make_Cons ( Make_Cons (
Interp.Self, Interp.Self,
P, P,
@ -2432,59 +2534,8 @@ Print (Interp, Operand);
end Apply; end Apply;
procedure Read_Object is 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 begin
null; 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; end Read_Object;
begin begin

53
lib/h2-scheme.ads
View File

@ -37,14 +37,7 @@
with System; with System;
with System.Storage_Pools; with System.Storage_Pools;
with Ada.Unchecked_Conversion; 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;
-- TODO: delete above after debugging
package H2.Scheme is package H2.Scheme is
@ -129,12 +122,11 @@ package H2.Scheme is
type Object_Byte is mod 2 ** System.Storage_Unit; type Object_Byte is mod 2 ** System.Storage_Unit;
for Object_Byte'Size use System.Storage_Unit; for Object_Byte'Size use System.Storage_Unit;
--subtype Object_Character is Standard.Wide_Character; subtype Object_Character is Standard.Wide_Character;
--subtype Object_String is Standard.Wide_String; subtype Object_String is Standard.Wide_String;
--package Text_IO renames Ada.Wide_Text_IO;
subtype Object_Character is Standard.Character; type Object_String_Pointer is access all Object_String;
subtype Object_String is Standard.String; type Constant_Object_String_Pointer is access constant Object_String;
package Text_IO renames Ada.Text_IO;
type Object_Byte_Array is array (Object_Size range <>) of Object_Byte; type Object_Byte_Array is array (Object_Size range <>) of Object_Byte;
type Object_Character_Array is array (Object_Size range <>) of Object_Character; type Object_Character_Array is array (Object_Size range <>) of Object_Character;
@ -307,7 +299,7 @@ package H2.Scheme is
type Stream_Allocator is access type Stream_Allocator is access
procedure (Interp: in out Interpreter_Record; procedure (Interp: in out Interpreter_Record;
Name: access Object_String; Name: Constant_Object_String_Pointer;
Result: out Stream_Pointer); Result: out Stream_Pointer);
type Stream_Deallocator is access type Stream_Deallocator is access
@ -322,15 +314,23 @@ package H2.Scheme is
type IO_Record; type IO_Record;
type IO_Pointer is access all IO_Record; type IO_Pointer is access all IO_Record;
type Character_Kind is (End_Character, Normal_Character, Error_Character);
type IO_Character_Record is record
Kind: Character_Kind := End_Character;
Value: Object_Character := Object_Character'First;
end record;
--pragma Pack (IO_Character_Record);
type IO_Record is record type IO_Record is record
--type IO_Record is limited record --type IO_Record is limited record
Stream: Stream_Pointer := null; Stream: Stream_Pointer := null;
--Data: Object_String(1..2048) := (others => ' '); --Data: Object_String(1..2048) := (others => Object_Character'First);
Data: Object_String(1..5) := (others => ' '); Data: Object_String(1..5) := (others => Object_Character'First);
Last: Standard.Natural := 0; Last: Standard.Natural := 0;
Pos: Standard.Natural := 0; Pos: Standard.Natural := 0;
Flags: IO_Flags := 0; -- EOF, ERROR Flags: IO_Flags := 0; -- EOF, ERROR
Next: IO_Pointer; Next: IO_Pointer := null;
Iochar: IO_Character_Record; -- the last character read.
end record; end record;
@ -437,6 +437,18 @@ private
Next: Object_Pointer := Nil_Pointer; Next: Object_Pointer := Nil_Pointer;
end record; end record;
type Token_Kind is (End_Token,
Identifier_Token,
Left_Parenthesis_Token,
Right_Parenthesis_Token,
Single_Quote_Token
);
type Token_Record is record
Kind: Token_Kind;
Value: Object_String;
end record;
--type Interpreter_Record is tagged limited record --type Interpreter_Record is tagged limited record
type Interpreter_Record is limited record type Interpreter_Record is limited record
--Self: Interpreter_Pointer := null; --Self: Interpreter_Pointer := null;
@ -457,9 +469,10 @@ private
R: Register_Record; R: Register_Record;
-- TODO: Buffer_Record needs to be stacked to handle "load". Base_Input: aliased IO_Record;
Input: aliased IO_Record; Input: IO_Pointer := null;
IO: IO_Pointer := null;
Token: Token_Record;
end record; end record;
end H2.Scheme; end H2.Scheme;

2
lib/h2.ads
View File

@ -2,8 +2,6 @@ with System.Storage_Pools;
package H2 is package H2 is
--subtype Character is Standard.Wide_Character;
type Storage_Pool_Pointer is type Storage_Pool_Pointer is
access all System.Storage_Pools.Root_Storage_Pool'Class; access all System.Storage_Pools.Root_Storage_Pool'Class;