diff --git a/cmd/scheme.adb b/cmd/scheme.adb index 55e04e9..74c1a0f 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -1,30 +1,33 @@ -with H2.Scheme; +with H2.Wide; +with H2.Slim; with H2.Pool; with Storage; -with Stream; +with Slim_Stream; +with Wide_Stream; with Ada.Text_IO; with Ada.Unchecked_Deallocation; procedure scheme is - --package S renames H2.Scheme; - --package S is new H2.Scheme (Wide_Character, Wide_String); - package S renames Stream.S; + --package Stream renames Wide_Stream; + --package Scheme renames H2.Wide.Scheme; + package Stream renames Slim_Stream; + package Scheme renames H2.Slim.Scheme; + Pool: aliased Storage.Global_Pool; - SI: S.Interpreter_Record; + SI: Scheme.Interpreter_Record; - I: S.Object_Pointer; - O: S.Object_Pointer; + I: Scheme.Object_Pointer; + O: Scheme.Object_Pointer; --String: aliased S.Object_String := "(car '(1 2 3))"; - String: aliased constant S.Object_Character_Array := "((lambda (x y) (+ x y)) 9 7)"; + String: aliased constant Scheme.Object_Character_Array := "((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_Character_Array := "test.adb"; - File_Name: aliased constant S.Object_Character_Array := "test.scm"; + File_Name: aliased constant Scheme.Object_Character_Array := "test.scm"; --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; @@ -35,33 +38,32 @@ procedure scheme is begin --h2init; - 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); + Scheme.Open (SI, 2_000_000, Pool'Unchecked_Access); + --Scheme.Open (SI, null); -- Specify the named stream handler - S.Set_Option (SI, (S.Stream_Option, + Scheme.Set_Option (SI, (Scheme.Stream_Option, Stream.Allocate_Stream'Access, Stream.Deallocate_Stream'Access) ); -S.Set_Option (SI, (S.Trait_Option, S.No_Optimization)); +Scheme.Set_Option (SI, (Scheme.Trait_Option, Scheme.No_Optimization)); File_Stream.Name := File_Name'Unchecked_Access; begin - S.Set_Input_Stream (SI, File_Stream); -- specify main input stream - --S.Set_Input_Stream (SI, String_Stream); + Scheme.Set_Input_Stream (SI, File_Stream); -- specify main input stream + --Schee.Set_Input_Stream (SI, String_Stream); exception when others => Ada.Text_IO.Put_Line ("Cannot open Input Stream"); end; - --S.Set_Output_Stream (SI, Stream); -- specify main output stream. + --Scheme.Set_Output_Stream (SI, Stream); -- specify main output stream. Ada.Text_IO.Put_Line ("-------------------------------------------"); -S.Run_Loop (SI, I); -S.Print (SI, I); - S.Close (SI); +Scheme.Run_Loop (SI, I); +Scheme.Print (SI, I); + Scheme.Close (SI); Ada.Text_IO.Put_Line ("BYE..."); diff --git a/cmd/scheme.gpr.in b/cmd/scheme.gpr.in index 597d11c..0576875 100644 --- a/cmd/scheme.gpr.in +++ b/cmd/scheme.gpr.in @@ -15,8 +15,10 @@ project Scheme is for Source_Files use ( "storage.ads", "storage.adb", - "stream.ads", - "stream.adb", + "slim_stream.ads", + "slim_stream.adb", + "wide_stream.ads", + "wide_stream.adb", "scheme.adb" ); for Object_Dir use "@ADA_OBJDIR@"; diff --git a/cmd/slim_stream.adb b/cmd/slim_stream.adb new file mode 100644 index 0000000..4c5743a --- /dev/null +++ b/cmd/slim_stream.adb @@ -0,0 +1,125 @@ +with H2.Pool; +with Ada.Unchecked_Conversion; + +package body Slim_Stream is + + use type S.Object_Size; + + ------------------------------------------------------------------ + + procedure Open (Stream: in out String_Input_Stream_Record) is + begin +Ada.Text_IO.Put_Line ("****** OPEN SLIM STRING STREAM ******"); + Stream.Pos := 0; + end Open; + + procedure Close (Stream: in out String_Input_Stream_Record) is + begin +Ada.Text_IO.Put_Line ("****** CLOSE SLIM STRING STREAM ******"); + Stream.Pos := Stream.Str'Last; + end Close; + + procedure Read (Stream: in out String_Input_Stream_Record; + Data: out S.Object_Character_Array; + Last: out S.Object_Size) is + Avail: S.Object_Size; + 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_Character_Array; + Last: out S.Object_Size) 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 SLIM FILE STREAM <<<<< " & Standard.String(Stream.Name.all)); + Ada.Text_IO.Open (Stream.Handle, Ada.Text_IO.In_File, Standard.String(Stream.Name.all)); + end Open; + + procedure Close (Stream: in out File_Stream_Record) is + begin +Ada.Text_IO.Put_Line (">>>>> CLOSE SLIM FILE STREAM <<<<< " & Standard.String(Stream.Name.all)); + Ada.Text_IO.Close (Stream.Handle); + end Close; + + procedure Read (Stream: in out File_Stream_Record; + Data: out S.Object_Character_Array; + Last: out S.Object_Size) is + begin + for I in Data'First .. Data'Last loop + begin + if Ada.Text_IO.End_Of_File (Stream.Handle) then + Last := I - 1; + return; + end if; + + Ada.Text_IO.Get_Immediate (Stream.Handle, Data(I)); + --Ada.Text_IO.Get (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_Character_Array; + Last: out S.Object_Size) is + begin + --raise S.Stream_Error; + Last := Data'First - 1; + end Write; + + ------------------------------------------------------------------ + + procedure Allocate_Stream (Interp: in out S.Interpreter_Record; + Name: access S.Object_Character_Array; + Result: out S.Stream_Pointer) is + subtype FSR is 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 := S.Constant_Object_Character_Array_Pointer(Name); + end Allocate_Stream; + + procedure Deallocate_Stream (Interp: in out S.Interpreter_Record; + Source: in out S.Stream_Pointer) is + subtype FSR is 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 Slim_Stream; diff --git a/cmd/slim_stream.ads b/cmd/slim_stream.ads new file mode 100644 index 0000000..b04048a --- /dev/null +++ b/cmd/slim_stream.ads @@ -0,0 +1,55 @@ +with H2.Slim; +with Ada.Text_IO; + +package Slim_Stream is + + package S renames H2.Slim.Scheme; + + ------------------------------------------------------------ + --type Object_Character_Array_Pointer is access all S.Object_Character_Array; + type Object_Character_Array_Pointer is access constant S.Object_Character_Array; + type String_Input_Stream_Record(Str: Object_Character_Array_Pointer) is new S.Stream_Record with record + Pos: S.Object_Size := 0; + 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_Character_Array; + Last: out S.Object_Size); + procedure Write (Stream: in out String_Input_Stream_Record; + Data: out S.Object_Character_Array; + Last: out S.Object_Size); + + ------------------------------------------------------------ + + type File_Stream_Record is new S.Stream_Record with record + Name: S.Constant_Object_Character_Array_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_Character_Array; + Last: out S.Object_Size); + procedure Write (Stream: in out File_Stream_Record; + Data: out S.Object_Character_Array; + Last: out S.Object_Size); + + ------------------------------------------------------------ + procedure Allocate_Stream (Interp: in out S.Interpreter_Record; + Name: access S.Object_Character_Array; + 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_Character_Array_Pointer; +-- Handle: Ada.Text_IO.File_Type; +-- end record; + +end Slim_Stream; + diff --git a/cmd/stream.adb b/cmd/wide_stream.adb similarity index 86% rename from cmd/stream.adb rename to cmd/wide_stream.adb index 3dec01b..17d1616 100644 --- a/cmd/stream.adb +++ b/cmd/wide_stream.adb @@ -3,20 +3,22 @@ with Ada.Unchecked_Conversion; with Ada.Text_IO; -- for debugging -package body Stream is +package body Wide_Stream is + + package Utf8 renames H2.Wide.Utf8; + use type S.Object_Size; ------------------------------------------------------------------ - use type S.Object_Size; procedure Open (Stream: in out String_Input_Stream_Record) is begin -Ada.Text_IO.Put_Line ("****** OPEN STRING STREAM ******"); +Ada.Text_IO.Put_Line ("****** OPEN WIDE 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 ******"); +Ada.Text_IO.Put_Line ("****** CLOSE WIDE STRING STREAM ******"); Stream.Pos := Stream.Str'Last; end Close; @@ -52,7 +54,7 @@ Ada.Text_IO.Put_Line ("****** CLOSE STRING STREAM ******"); procedure Open (Stream: in out File_Stream_Record) is begin -Ada.Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all)))); +Ada.Text_IO.Put_Line (">>>>> OPEN WIDE FILE STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all)))); --Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Standard.Wide_String(Stream.Name.all))); Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all)))); end Open; @@ -62,7 +64,7 @@ Ada.Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<< " & Standard.String(Utf8.Uni function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_Character_Array, Wide_String); begin --Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.Wide_String(Stream.Name.all)); -Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all)))); +Ada.Text_IO.Put_Line (">>>>> CLOSE WIDE FILE STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all)))); Ada.Wide_Text_IO.Close (Stream.Handle); end Close; @@ -100,7 +102,7 @@ Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Un procedure Allocate_Stream (Interp: in out S.Interpreter_Record; Name: access S.Object_Character_Array; Result: out S.Stream_Pointer) is - subtype FSR is Stream.File_Stream_Record; + subtype FSR is File_Stream_Record; type FSP is access all FSR; package P is new H2.Pool (FSR, FSP); @@ -114,7 +116,7 @@ Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Un procedure Deallocate_Stream (Interp: in out S.Interpreter_Record; Source: in out S.Stream_Pointer) is - subtype FSR is Stream.File_Stream_Record; + subtype FSR is File_Stream_Record; type FSP is access all FSR; package P is new H2.Pool (FSR, FSP); @@ -124,4 +126,4 @@ Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Un begin P.Deallocate (X, S.Get_Storage_Pool(Interp)); end Deallocate_Stream; -end Stream; +end Wide_Stream; diff --git a/cmd/stream.ads b/cmd/wide_stream.ads similarity index 97% rename from cmd/stream.ads rename to cmd/wide_stream.ads index 857cd6e..5e08c24 100644 --- a/cmd/stream.ads +++ b/cmd/wide_stream.ads @@ -1,10 +1,9 @@ with H2.Wide; with Ada.Wide_Text_IO; -package Stream is +package Wide_Stream is package S renames H2.Wide.Scheme; - package Utf8 renames H2.Wide.Utf8; ------------------------------------------------------------ --type Object_Character_Array_Pointer is access all S.Object_Character_Array; @@ -52,5 +51,5 @@ package Stream is -- Handle: Ada.Wide_Text_IO.File_Type; -- end record; -end Stream; +end Wide_Stream; diff --git a/lib/h2-scheme-bigint.adb b/lib/h2-scheme-bigint.adb index ac1dca5..72ec0c8 100644 --- a/lib/h2-scheme-bigint.adb +++ b/lib/h2-scheme-bigint.adb @@ -287,8 +287,8 @@ package body Bigint is begin if Is_Integer(A) and then Is_Integer(B) then declare - pragma Unsuppress (Range_Check); - pragma Unsuppress (Overflow_Check); + --pragma Unsuppress (Range_Check); + --pragma Unsuppress (Overflow_Check); G: Object_Integer := Pointer_To_Integer(A); H: Object_Integer := Pointer_To_Integer(B); diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index b4e286d..5dcf932 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -570,7 +570,7 @@ procedure Execute (Interp: in out Interpreter_Record) is --return; raise IO_Error; 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.Iochar := (End_Character, Object_Character'First); diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index a6ca415..1a5b899 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -1236,7 +1236,6 @@ end if; end Make_Cons; function Is_Cons (Source: in Object_Pointer) return Standard.Boolean is - pragma Inline (Is_Cons); begin return Is_Normal_Pointer(Source) and then Source.Tag = Cons_Object; @@ -1439,7 +1438,6 @@ end if; end Make_Bigint; function Is_Bigint (Source: in Object_Pointer) return Standard.Boolean is - pragma Inline (Is_Bigint); begin return Is_Normal_Pointer(Source) and then Source.Tag = Bigint_Object; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index d5d39ed..8b0b898 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -335,6 +335,8 @@ package H2.Scheme is function Is_Cons (Source: in Object_Pointer) return Standard.Boolean; function Is_Bigint (Source: in Object_Pointer) return Standard.Boolean; + pragma Inline (Is_Cons); + pragma Inline (Is_Bigint); -- ----------------------------------------------------------------------------- diff --git a/lib/h2-slim.ads b/lib/h2-slim.ads new file mode 100755 index 0000000..4f21175 --- /dev/null +++ b/lib/h2-slim.ads @@ -0,0 +1,7 @@ +with H2.Scheme; + +package H2.Slim is + + package Scheme is new H2.Scheme (Standard.Character); + +end H2.Slim; diff --git a/lib/lib.gpr.in b/lib/lib.gpr.in index 5d2368c..72c0845 100644 --- a/lib/lib.gpr.in +++ b/lib/lib.gpr.in @@ -19,6 +19,7 @@ project Lib is "h2-scheme-execute-apply.adb", "h2-scheme-execute-evaluate.adb", "h2-scheme-token.adb", + "h2-slim.ads", "h2-utf8.adb", "h2-utf8.ads", "h2-wide.ads" @@ -28,6 +29,7 @@ project Lib is "h2.ascii", "h2.pool", "h2.scheme", + "h2.slim", "h2.utf8", "h2.wide" );