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

redefined Object_String for simpler string handling and made other related changes

Browse Source
This commit is contained in:
hyung-hwan 2014-01-10 14:54:46 +00:00
parent bec5235659
commit 24829df3a6
7 changed files with 100 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cmd/scheme.adb
View File

@ -1,3 +1,4 @@
with H2.Scheme;
with H2.Pool;
with Storage;
@ -5,6 +6,7 @@ with 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);

22
cmd/stream.adb
View File

@ -1,9 +1,11 @@
with H2.Pool;
with Ada.Characters.Conversions;
with Ada.Unchecked_Conversion;
package body Stream is
------------------------------------------------------------------
use type S.Object_String_Size;
procedure Open (Stream: in out String_Input_Stream_Record) is
begin
@ -19,8 +21,8 @@ Ada.Wide_Text_IO.Put_Line ("****** CLOSE STRING STREAM ******");
procedure Read (Stream: in out String_Input_Stream_Record;
Data: out S.Object_String;
Last: out Standard.Natural) is
Avail: Standard.Natural;
Last: out S.Object_String_Size) is
Avail: S.Object_String_Size;
begin
Avail := Stream.Str'Last - Stream.Pos;
if Avail <= 0 then
@ -39,7 +41,7 @@ Ada.Wide_Text_IO.Put_Line ("****** CLOSE STRING STREAM ******");
procedure Write (Stream: in out String_Input_Stream_Record;
Data: out S.Object_String;
Last: out Standard.Natural) is
Last: out S.Object_String_Size) is
begin
--raise S.Stream_Error;
Last := Data'First - 1;
@ -48,20 +50,24 @@ Ada.Wide_Text_IO.Put_Line ("****** CLOSE STRING STREAM ******");
------------------------------------------------------------------
procedure Open (Stream: in out File_Stream_Record) is
subtype Wide_String is Standard.Wide_String(1 .. Standard.Natural(Stream.Name'Length));
function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_String, Wide_String);
begin
Ada.Wide_Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<<");
Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Stream.Name.all));
Ada.Wide_Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<< " & To_Wide_String(Stream.Name.all));
Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(To_Wide_String(Stream.Name.all)));
end Open;
procedure Close (Stream: in out File_Stream_Record) is
subtype Wide_String is Standard.Wide_String(1 .. Standard.Natural(Stream.Name'Length));
function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_String, Wide_String);
begin
Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<<");
Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & To_Wide_String(Stream.Name.all));
Ada.Wide_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
Last: out S.Object_String_Size) is
begin
for I in Data'First .. Data'Last loop
begin
@ -78,7 +84,7 @@ Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<<");
procedure Write (Stream: in out File_Stream_Record;
Data: out S.Object_String;
Last: out Standard.Natural) is
Last: out S.Object_String_Size) is
begin
--raise S.Stream_Error;
Last := Data'First - 1;

22
cmd/stream.ads
View File

@ -3,49 +3,39 @@ with Ada.Wide_Text_IO;
package Stream is
--package S renames H2.Scheme;
package S is new H2.Scheme (Standard.Wide_Character, Standard.Wide_String);
package S is new H2.Scheme (Standard.Wide_Character);
------------------------------------------------------------
--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
Pos: Standard.Natural := 0;
Pos: S.Object_String_Size := 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);
Last: out S.Object_String_Size);
procedure Write (Stream: in out String_Input_Stream_Record;
Data: out S.Object_String;
Last: out Standard.Natural);
Last: out S.Object_String_Size);
------------------------------------------------------------
--type File_Stream_Record(Name: Object_String_Pointer) is new S.Stream_Record with record
-- Handle: H2.Text_IO.File_Type;
--end record;
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;
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);
Last: out S.Object_String_Size);
procedure Write (Stream: in out File_Stream_Record;
Data: out S.Object_String;
Last: out Standard.Natural);
Last: out S.Object_String_Size);
------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record;

2
lib/ascii.awk
View File

@ -1,3 +1,5 @@
# This script requires QSEAWK.
BEGIN {
printf ("-- Generated with ascii.txt and ascii.awk\n");
printf ("-- Run qseawk -f ascii.awk ascii.txt > h2-ascii.ads for regeneration\n\n");

6
lib/h2-scheme-token.adb
View File

@ -10,7 +10,7 @@ package body Token is
procedure Clear_Buffer (Buffer: in out Buffer_Record) is
pragma Inline (Clear_Buffer);
begin
Buffer.Last := 0;
Buffer.Last := 0;
end Clear_Buffer;
procedure Purge_Buffer (Interp: in out Interpreter_Record;
@ -31,14 +31,14 @@ package body Token is
Pool.Deallocate (Tmp);
end;
Buffer := (null, 0, 0);
Buffer := ( Ptr => null, Len => 0, Last => 0);
end if;
end Purge_Buffer;
procedure Append_Buffer (Interp: in out Interpreter_Record;
Buffer: in out Buffer_Record;
Source: in Object_String) is
Incr: Standard.Natural;
Incr: Object_String_Size;
begin
if Buffer.Last >= Buffer.Len then
if Buffer.Len <= 0 then

190
lib/h2-scheme.adb
View File

@ -125,6 +125,19 @@ package body H2.Scheme is
function Get_New_Location (Object: in Object_Pointer) return Object_Pointer;
pragma Inline (Get_New_Location);
-----------------------------------------------------------------------------
-- FOR DEBUGGING. REMVOE THESE LATER
-----------------------------------------------------------------------------
procedure Output_Character_Array (Source: in Object_Character_Array) is
-- for debugging only.
begin
for I in Source'Range loop
--Ada.Text_IO.Put (Source(I));
-- TODO: note this is a hack for quick printing.
Ada.Text_IO.Put (Standard.Character'Val(Object_Character'Pos(Source(I))));
end loop;
end Output_Character_Array;
-----------------------------------------------------------------------------
-- POINTER AND DATA CONVERSION
-----------------------------------------------------------------------------
@ -262,104 +275,6 @@ package body H2.Scheme is
return Object_Byte(Word / (2 ** Object_Pointer_Type_Bits));
end Pointer_To_Byte;
-- Check if a character object contains a given string in the payload.
function Match (Object: in Object_Pointer;
Data: in Object_String) return Standard.Boolean is
Slot: Object_Character_Array renames Object.Character_Slot;
begin
return Slot(Slot'First .. Slot'Last - 1) = Object_Character_Array(Data);
end;
procedure Copy_String (Source: in Object_String;
Target: out Object_Character_Array) is
begin
-- This procedure is not generic. The size of the Source
-- and Target must be in the expected length.
pragma Assert (Source'Length + 1 = Target'Length);
-- Method 1. Naive. It doesn't look Adaish.
-- ---------------------------------------------------------------------
--declare
-- X: Object_Size;
--begin
-- X := Target'First;
-- for I in Source'Range loop
-- Target(X) := Source(I);
-- X := X + 1;
-- end loop;
-- Target(X) := Object_Character'First; -- Object_Character'Val(0);
--end;
-- Method 2.
-- ObjectAda complains that the member of Object_String is not
-- aliased because Object_Character_Array is an array of aliased
-- Object_Character.It points to LRM 4.6(12); The component subtypes
-- shall statically match.
-- ---------------------------------------------------------------------
--Target(Target'First .. Target'Last - 1) := Object_Character_Array (Source(Source'First .. Source'Last));
--Target(Target'Last) := Object_Character'First; -- Object_Character'Val(0);
-- Method 3. Use unchecked conversion
declare
subtype Character_Array is Object_Character_Array (Target'First .. Target'Last - 1);
function To_Character_Array is new Ada.Unchecked_Conversion (Object_String, Character_Array);
begin
Target(Target'First .. Target'Last - 1) := To_Character_Array(Source);
Target(Target'Last) := Object_Character'First; -- Object_Character'Val(0);
end;
end Copy_String;
procedure Copy_String (Source: in Object_Character_Array;
Target: out Object_String) is
begin
pragma Assert (Source'Length = Target'Length + 1);
--declare
-- X: Standard.Natural;
--begin
-- X := Target'First;
-- for I in Source'First .. Source'Last - 1 loop
-- Target(X) := Source(I);
-- X := X + 1;
-- end loop;
--end;
declare
subtype Character_Array is Object_Character_Array (Source'First .. Source'Last - 1);
subtype String_Array is Object_String (Target'Range);
function To_Character_Array is new Ada.Unchecked_Conversion(Character_Array, String_Array);
begin
Target := To_Character_Array (Source (Source'First .. Source'Last - 1));
end;
end Copy_String;
function Character_Array_To_String (Source: in Object_Character_Array) return Object_String is
begin
-- ObjectAda complains that the member of Object_String is not
-- aliased because Object_Character_Array is an array of aliased
-- Object_Character. It points to LRM 4.6(12); The component subtypes
-- shall statically match. So let me turn to unchecked conversion.
declare
subtype Character_Array is Object_Character_Array (Source'First .. Source'Last - 1);
subtype String_Array is Object_String (1 .. Source'Length - 1);
function To_Character_Array is new Ada.Unchecked_Conversion (Character_Array, String_Array);
begin
return To_Character_Array (Source (Source'First .. Source'Last - 1));
--return String_Array (Source (Source'First .. Source'Last - 1));
end;
end Character_Array_To_String;
--Text_IO.Put (Character_Array_To_String (Atom.Character_Slot));
procedure Output_Character_Array (Source: in Object_Character_Array) is
-- for debugging only.
begin
for I in Source'First .. Source'Last loop
--Ada.Text_IO.Put (Source(I));
-- TODO: note this is a hack for quick printing.
Ada.Text_IO.Put (Standard.Character'Val(Object_Character'Pos(Source(I))));
end loop;
end Output_Character_Array;
-- TODO: move away these utilities routines
--function To_Thin_String_Pointer (Source: in Object_Pointer) return Thin_String_Pointer is
-- type Character_Pointer is access all Object_Character;
@ -410,11 +325,9 @@ package body H2.Scheme is
" at " & Object_Kind'Image(Source.Kind) &
" size " & Object_Size'Image(Source.Size) & " - ");
if Source.Kind = Moved_Object then
--Text_IO.Put_Line (Character_Array_To_String (Get_New_Location(Source).Character_Slot));
null;
Output_Character_Array (Get_New_Location(Source).Character_Slot);
else
--Text_IO.Put_Line (Character_Array_To_String (Source.Character_Slot));
null;
Output_Character_Array (Source.Character_Slot);
end if;
else
Ada.Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W) & " at " & Object_Kind'Image(Source.Kind));
@ -424,7 +337,7 @@ package body H2.Scheme is
function String_To_Integer_Pointer (Source: in Object_String) return Object_Pointer is
V: Object_Integer := 0;
Negative: Standard.Boolean := False;
First: Standard.Natural;
First: Object_String_Size;
begin
-- TODO: BIGNUM, RANGE CHECK, ETC
pragma Assert (Source'Length > 0);
@ -842,7 +755,8 @@ Ada.Text_IO.Put_Line (">>> [GC DONE]");
Flags => 0,
Scode => 0,
Tag => Unknown_Object,
Character_Slot => (others => Object_Character'First)
Character_Slot => (others => Ch.NUL),
Character_Terminator => Ch.NUL
);
return Result;
@ -857,7 +771,7 @@ Ada.Text_IO.Put_Line (">>> [GC DONE]");
end if;
Result := Allocate_Character_Object (Interp, Character_Object_Size'(Source'Length));
Copy_String (Source, Result.Character_Slot);
Result.Character_Slot := Source;
return Result;
end Allocate_Character_Object;
@ -981,6 +895,7 @@ Ada.Text_IO.Put_Line (">>> [GC DONE]");
Source: in Object_String) return Object_Pointer is
Result: Object_Pointer;
begin
Ada.Text_IO.Put_Line ("Make_String...");
Result := Allocate_Character_Object (Interp, Source);
Result.Tag := String_Object;
--Print_Object_Pointer ("Make_String Result - " & Source, Result);
@ -1013,7 +928,8 @@ Ada.Text_IO.Put_Line (">>> [GC DONE]");
--Text_IO.Put_Line (Car.Kind'Img & Car.Tag'Img & Object_Word'Image(Pointer_To_Word(Car)));
pragma Assert (Car.Tag = Symbol_Object);
if Match(Car, Source) then
--if Match_Character_Object(Car, Source) then
if Car.Character_Slot = Source then
return Car;
--Print_Object_Pointer ("Make_Symbol Result (Existing) - " & Source, Car);
end if;
@ -1124,7 +1040,7 @@ Ada.Text_IO.Put_Line (">>> [GC DONE]");
if Arr = null then
-- Add a new key/value pair
-- TODO: make it GC-aware - protect Key and Value
Arr := Make_Array (Interp.Self, 3);
Arr := Make_Array(Interp.Self, 3);
Arr.Pointer_Slot(1) := Key;
Arr.Pointer_Slot(2) := Value;
@ -1558,7 +1474,9 @@ Ada.Text_IO.Put_Line ("1111111111");
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;
Ada.Text_IO.Put_Line ("11111111111111111111111111111111111111");
Make_Syntax_Objects;
Ada.Text_IO.Put_Line ("2222222222222222222222222");
Make_Procedure_Objects;
Ada.Text_IO.Put_Line ("99999");
@ -1662,37 +1580,37 @@ Ada.Text_IO.Put_Line (IO_Character_Record'Max_Size_In_Storage_Elements'Img);
when others =>
case Atom.Tag is
when Cons_Object =>
-- Cons_Object must not reach here.
raise Internal_Error;
when Cons_Object =>
-- Cons_Object must not reach here.
raise Internal_Error;
when Symbol_Object =>
Output_Character_Array (Atom.Character_Slot);
when String_Object =>
Ada.Text_IO.Put ("""");
Output_Character_Array (Atom.Character_Slot);
Ada.Text_IO.Put ("""");
when Closure_Object =>
Ada.Text_IO.Put ("#Closure");
when Continuation_Object =>
Ada.Text_IO.Put ("#Continuation");
when Procedure_Object =>
Ada.Text_IO.Put ("#Procedure");
when Array_Object =>
Ada.Text_IO.Put ("#Array");
when Others =>
if Atom.Kind = Character_Object then
when Symbol_Object =>
Output_Character_Array (Atom.Character_Slot);
else
Ada.Text_IO.Put ("#NOIMPL#");
end if;
end case;
when String_Object =>
Ada.Text_IO.Put ("""");
Output_Character_Array (Atom.Character_Slot);
Ada.Text_IO.Put ("""");
when Closure_Object =>
Ada.Text_IO.Put ("#Closure");
when Continuation_Object =>
Ada.Text_IO.Put ("#Continuation");
when Procedure_Object =>
Ada.Text_IO.Put ("#Procedure");
when Array_Object =>
Ada.Text_IO.Put ("#Array");
when Others =>
if Atom.Kind = Character_Object then
Output_Character_Array (Atom.Character_Slot);
else
Ada.Text_IO.Put ("#NOIMPL#");
end if;
end case;
end case;
end Print_Pointee;

36
lib/h2-scheme.ads
View File

@ -41,7 +41,6 @@ with Ada.Unchecked_Conversion;
generic
type Character_Type is (<>);
type String_Type is array (Standard.Positive range<>) of Character_Type;
package H2.Scheme is
type Interpreter_Record is limited private;
@ -125,16 +124,16 @@ package H2.Scheme is
type Object_Byte is mod 2 ** System.Storage_Unit;
for Object_Byte'Size use System.Storage_Unit;
--subtype Object_Character is Standard.Wide_Character;
--subtype Object_String is Standard.Wide_String;
subtype Object_Character is Character_Type;
subtype Object_String is String_Type;
subtype Object_String_Size is Object_Size range 0 .. Object_Size'Last - 1;
subtype Object_String_Range is Object_Size range 1 .. Object_Size'Last - 1;
type Object_String is array (Object_String_Range range <>) of Object_Character;
type Object_String_Pointer is access all Object_String;
type Constant_Object_String_Pointer is access constant Object_String;
type Object_Byte_Array is array (Object_Size range <>) of Object_Byte;
type Object_Character_Array is array (Object_Size range <>) of Object_Character;
subtype Object_Character_Array is Object_String;
type Object_Pointer_Array is array (Object_Size range <>) of Object_Pointer;
type Object_Word_Array is array (Object_Size range <>) of Object_Word;
@ -201,7 +200,7 @@ package H2.Scheme is
Mark_Object
);
type Object_Record (Kind: Object_Kind; Size: Object_Size) is record
type Object_Record(Kind: Object_Kind; Size: Object_Size) is record
Flags: Object_Flags := 0;
Scode: Syntax_Code := 0;
Tag: Object_Tag := Unknown_Object;
@ -215,13 +214,14 @@ package H2.Scheme is
when Moved_Object =>
New_Pointer: Object_Pointer := null;
when Pointer_Object =>
Pointer_Slot: Object_Pointer_Array (1 .. Size) := (others => null);
Pointer_Slot: Object_Pointer_Array(1 .. Size) := (others => null);
when Character_Object =>
Character_Slot: Object_Character_Array (0 .. Size) := (others => Object_Character'First);
Character_Slot: Object_Character_Array(1 .. Size) := (others => Object_Character'First);
Character_Terminator: Object_Character := Object_Character'First; -- TODO: can this guarantee termining NULL? require some attribute for it to work?
when Byte_Object =>
Byte_Slot: Object_Byte_Array (1 .. Size) := (others => 0);
Byte_Slot: Object_Byte_Array(1 .. Size) := (others => 0);
when Word_Object =>
Word_Slot: Object_Word_Array (1 .. Size) := (others => 0);
Word_Slot: Object_Word_Array(1 .. Size) := (others => 0);
end case;
end record;
for Object_Record use record
@ -294,11 +294,11 @@ package H2.Scheme is
procedure Read (Stream: in out Stream_Record;
Data: out Object_String;
Last: out Standard.Natural) is abstract;
Last: out Object_String_Size) is abstract;
procedure Write (Stream: in out Stream_Record;
Data: out Object_String;
Last: out Standard.Natural) is abstract;
Last: out Object_String_Size) is abstract;
type Stream_Pointer is access all Stream_Record'Class;
@ -331,8 +331,8 @@ package H2.Scheme is
Stream: Stream_Pointer := null;
--Data: Object_String(1..2048) := (others => Object_Character'First);
Data: Object_String(1..5) := (others => Object_Character'First);
Last: Standard.Natural := 0;
Pos: Standard.Natural := 0;
Last: Object_String_Size := 0;
Pos: Object_String_Size := 0;
Flags: IO_Flags := 0; -- EOF, ERROR
Next: IO_Pointer := null;
Iochar: IO_Character_Record; -- the last character read.
@ -419,14 +419,16 @@ package H2.Scheme is
-- -----------------------------------------------------------------------------
subtype Thin_String is Object_String (Standard.Positive'Range);
subtype Thin_String is Object_String (Object_String_Range'Range);
type Thin_String_Pointer is access all Thin_String;
for Thin_String_Pointer'Size use Object_Pointer_Bits;
type Buffer_Record is record
Ptr: Thin_String_Pointer := null;
Len: Standard.Natural := 0;
Last: Standard.Natural := 0;
Len: Object_String_Size := 0;
Last: Object_String_Size := 0;
end record;
private
type Heap_Element_Array is array (Heap_Size range <>) of aliased Heap_Element;