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

added H2.Slim and Slim_Stream.

Browse Source 
renamed Stream to Wide_Stream.
This commit is contained in:
hyung-hwan
2014-03-26 14:28:41 +00:00
parent ed0835caae
commit 8ef3eabe78
12 changed files with 235 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

46
cmd/scheme.adb
View File

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

6
cmd/scheme.gpr.in
View File

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

125
cmd/slim_stream.adb Normal file
View File

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

55
cmd/slim_stream.ads Normal file
View File

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

20
cmd/stream.adb → cmd/wide_stream.adb
View File

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

5
cmd/stream.ads → cmd/wide_stream.ads
View File

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

4
lib/h2-scheme-bigint.adb
View File

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

2
lib/h2-scheme.adb
View File

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

2
lib/h2-scheme.ads
View File

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

7
lib/h2-slim.ads Executable file
View File

@ -0,0 +1,7 @@
with H2.Scheme;
package H2.Slim is
package Scheme is new H2.Scheme (Standard.Character);
end H2.Slim;

2
lib/lib.gpr.in
View File

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