From 24829df3a61ac680cc737a3c4c8a92d5ca42cbec Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Fri, 10 Jan 2014 14:54:46 +0000 Subject: [PATCH] redefined Object_String for simpler string handling and made other related changes --- cmd/scheme.adb | 2 + cmd/stream.adb | 22 +++-- cmd/stream.ads | 22 ++--- lib/ascii.awk | 2 + lib/h2-scheme-token.adb | 6 +- lib/h2-scheme.adb | 190 ++++++++++++---------------------------- lib/h2-scheme.ads | 36 ++++---- 7 files changed, 100 insertions(+), 180 deletions(-) diff --git a/cmd/scheme.adb b/cmd/scheme.adb index 1342962..520912f 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -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); diff --git a/cmd/stream.adb b/cmd/stream.adb index 84505dc..672fcd0 100644 --- a/cmd/stream.adb +++ b/cmd/stream.adb @@ -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; diff --git a/cmd/stream.ads b/cmd/stream.ads index 3bdb466..7c3051c 100644 --- a/cmd/stream.ads +++ b/cmd/stream.ads @@ -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; diff --git a/lib/ascii.awk b/lib/ascii.awk index a4b36cd..3155ca6 100644 --- a/lib/ascii.awk +++ b/lib/ascii.awk @@ -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"); diff --git a/lib/h2-scheme-token.adb b/lib/h2-scheme-token.adb index bbfcdab..7dd3428 100644 --- a/lib/h2-scheme-token.adb +++ b/lib/h2-scheme-token.adb @@ -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 diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 6484465..ed3bb99 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -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; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 8047364..7130d9d 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -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;