diff --git a/lib2/Makefile b/lib2/Makefile index 9e456ff..2952e7a 100644 --- a/lib2/Makefile +++ b/lib2/Makefile @@ -1,3 +1,14 @@ -all: - gnat make -gnata -gnatW8 hello && valgrind ./hello - gnat make -gnata -gnatW8 hello2 && valgrind ./hello2 +OPTS := -gnata -gnatW8 -gnatwa -gnatya -gnatyb -gnatyk -gnatyn -gnatyp ##-gnatyt +all: hello hello2 hello3 + +hello: hello.adb + gnat make $(OPTS) hello && valgrind ./hello + +hello2: hello2.adb + gnat make $(OPTS) hello2 && valgrind ./hello2 + +hello3: hello3.adb + gnat make $(OPTS) hello3 && valgrind ./hello3 + +clean: + rm -rf *.o *.ali hello hello2 hello3 diff --git a/lib2/h3-arrays.adb b/lib2/h3-arrays.adb index 9d737e4..727d4f1 100644 --- a/lib2/h3-arrays.adb +++ b/lib2/h3-arrays.adb @@ -52,12 +52,12 @@ package body H3.Arrays is return P; end Get_Slot_Pointer; - function Is_Shared(Obj: in Elastic_Array) return Standard.Boolean is + function Is_Shared(Obj: in Elastic_Array) return Boolean is begin return Obj.Buffer /= Empty_Buffer'Access and then Obj.Buffer.Refs > 1; end Is_Shared; - procedure Ref_Buffer (Buf: in out Buffer_Pointer) is + procedure Ref_Buffer (Buf: in Buffer_Pointer) is begin if Buf /= Empty_Buffer'Access then Buf.Refs := Buf.Refs + 1; @@ -88,14 +88,14 @@ package body H3.Arrays is return Tmp; end New_Buffer_Container; - -- prepare the buffer for writing + -- prepare the buffer for writing procedure Prepare_Buffer (Obj: in out Elastic_Array) is Tmp: Elastic_Array; begin if Obj.Buffer /= Empty_Buffer'Access then if Is_Shared(Obj) then -- The code like this doesn't work correctly in terms of finalization. - -- The buffer pointer held inside a finalization controlled record must be + -- The buffer pointer held inside a finalization controlled record must be -- manipluated through the record itself. otherwise, the Adjust and Finalize -- calls goes incompatible with the reference counting implementation. -- It is because finalization is set on the record rather than the buffer pointer. @@ -114,7 +114,7 @@ package body H3.Arrays is end if; end Prepare_Buffer; - -- prepare the buffer for writing + -- prepare the buffer for writing procedure Prepare_Buffer (Obj: in out Elastic_Array; Req_Hard_Capa: in System_Size; Shift_Pos: in System_Size := 0; Shift_Size: in System_Size := 0; Shift_Dir: in Direction := DIRECTION_FORWARD) is Tmp: Elastic_Array; First, Last: System_Size; @@ -158,11 +158,11 @@ package body H3.Arrays is end if; <> -- it is an internal function. perform no sanity check. - -- if Shift_Pos or Shift_Size is beyond the allocated capacity, + -- if Shift_Pos or Shift_Size is beyond the allocated capacity, -- it will end up in an exception. if Shift_Dir = DIRECTION_BACKWARD then declare - Mid: System_Size := Shift_Pos - Shift_Size; + Mid: constant System_Size := Shift_Pos - Shift_Size; begin Obj.Buffer.Slot(First .. Mid) := Tmp.Buffer.Slot(First .. Mid); Obj.Buffer.Slot(Mid + 1 .. Last - Shift_Size + Terminator_Length) := Tmp.Buffer.Slot(Shift_Pos + 1 .. Last + Terminator_Length); @@ -183,7 +183,7 @@ package body H3.Arrays is end Clear; procedure Purge (Obj: in out Elastic_Array) is - begin + begin Unref_Buffer (Obj.Buffer); Obj.Buffer := Empty_Buffer'Access; end Purge; @@ -195,7 +195,7 @@ package body H3.Arrays is procedure Insert (Obj: in out Elastic_Array; Pos: in System_Index; V: in Item_Type; Repeat: in System_Size := 1) is Act_Pos: System_Index := Pos; - Act_Inc: System_Size := Repeat; + Act_Inc: constant System_Size := Repeat; begin if Act_Pos > Obj.Buffer.Last then Act_Pos := Obj.Buffer.Last + 1; @@ -295,7 +295,7 @@ package body H3.Arrays is end if; end Delete; - function Find (Obj: in Elastic_Array; V: In Item_Type; Start_Pos: in System_Index; Find_Dir: in Direction := DIRECTION_FORWARD) return System_Size is + function Find (Obj: in Elastic_Array; V: in Item_Type; Start_Pos: in System_Index; Find_Dir: in Direction := DIRECTION_FORWARD) return System_Size is Act_Start_Pos: System_Index := Start_Pos; begin if Find_Dir = DIRECTION_FORWARD then @@ -321,7 +321,7 @@ package body H3.Arrays is return System_Size'First; end Find; - function Find (Obj: in Elastic_Array; V: In Item_Array; Start_Pos: in System_Index; Find_Dir: in Direction := DIRECTION_FORWARD) return System_Size is + function Find (Obj: in Elastic_Array; V: in Item_Array; Start_Pos: in System_Index; Find_Dir: in Direction := DIRECTION_FORWARD) return System_Size is End_Pos: System_Size; begin if Get_Length(Obj) > 0 and then V'Length > 0 and then V'Length <= Get_Length(Obj) then @@ -347,12 +347,12 @@ package body H3.Arrays is return System_Size'First; end Find; - function "=" (Obj: in Elastic_Array; Obj2: in Elastic_Array) return Standard.Boolean is + function "=" (Obj: in Elastic_Array; Obj2: in Elastic_Array) return Boolean is begin return Obj.Buffer = Obj2.Buffer or else Obj.Buffer.Slot(Get_First_Index(Obj) .. Get_Last_Index(Obj)) = Obj2.Buffer.Slot(Get_First_Index(Obj2) .. Get_Last_Index(Obj2)); end "="; - function "=" (Obj: in Elastic_Array; Obj2: in Item_Array) return Standard.Boolean is + function "=" (Obj: in Elastic_Array; Obj2: in Item_Array) return Boolean is begin return Obj.Buffer.Slot(Get_First_Index(Obj) .. Get_Last_Index(Obj)) = Obj2; end "="; diff --git a/lib2/h3-arrays.ads b/lib2/h3-arrays.ads index 9fba326..983a8c0 100644 --- a/lib2/h3-arrays.ads +++ b/lib2/h3-arrays.ads @@ -13,6 +13,7 @@ package H3.Arrays is type Direction is (DIRECTION_BACKWARD, DIRECTION_FORWARD); type Elastic_Array is tagged private; + --type Item_Array is array(System_Index range <>) of aliased Item_Type; type Item_Array is array(System_Index range <>) of Item_Type; --type Item_Array_Pointer is access all Item_Array; @@ -42,7 +43,7 @@ package H3.Arrays is function Get_Slot_Pointer (Obj: in Elastic_Array) return Thin_Item_Array_Pointer; pragma Inline (Get_Slot_Pointer); - function Is_Shared(Obj: in Elastic_Array) return Standard.Boolean; + function Is_Shared(Obj: in Elastic_Array) return Boolean; pragma Inline (Is_Shared); procedure Clear (Obj: in out Elastic_Array); @@ -56,17 +57,17 @@ package H3.Arrays is procedure Prepend (Obj: in out Elastic_Array; V: in Item_Type; Repeat: in System_Size := 1); procedure Prepend (Obj: in out Elastic_Array; V: in Item_Array); - + procedure Replace (Obj: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Type; Repeat: in System_Size := 1); procedure Replace (Obj: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Array); procedure Delete (Obj: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size); - function Find (Obj: in Elastic_Array; V: In Item_Type; Start_Pos: in System_Index; Find_Dir: in Direction := DIRECTION_FORWARD) return System_Size; - function Find (Obj: in Elastic_Array; V: In Item_Array; Start_Pos: in System_Index; Find_Dir: in Direction := DIRECTION_FORWARD) return System_Size; + function Find (Obj: in Elastic_Array; V: in Item_Type; Start_Pos: in System_Index; Find_Dir: in Direction := DIRECTION_FORWARD) return System_Size; + function Find (Obj: in Elastic_Array; V: in Item_Array; Start_Pos: in System_Index; Find_Dir: in Direction := DIRECTION_FORWARD) return System_Size; - function "=" (Obj: in Elastic_Array; Obj2: in Elastic_Array) return Standard.Boolean; - function "=" (Obj: in Elastic_Array; Obj2: in Item_Array) return Standard.Boolean; + function "=" (Obj: in Elastic_Array; Obj2: in Elastic_Array) return Boolean; + function "=" (Obj: in Elastic_Array; Obj2: in Item_Array) return Boolean; private type Buffer_Record(Capa: System_Size) is limited record diff --git a/lib2/h3-cc.adb b/lib2/h3-cc.adb index 2d3f7a2..5018efc 100644 --- a/lib2/h3-cc.adb +++ b/lib2/h3-cc.adb @@ -8,70 +8,70 @@ package body H3.CC is SP: constant Item_Type := Item_Type'Val(32); HT: constant Item_Type := Item_Type'Val(9); - function Is_Alpha (V: in Item_Type) return Standard.Boolean is + function Is_Alpha (V: in Item_Type) return Boolean is begin return UC.Is_UTF_32_Letter(Item_Type'Pos(V)); end Is_Alpha; - function Is_Alnum (V: in Item_Type) return Standard.Boolean is + function Is_Alnum (V: in Item_Type) return Boolean is begin return UC.Is_UTF_32_Letter(Item_Type'Pos(V)) or else UC.Is_UTF_32_Digit(Item_Type'Pos(V)); end Is_Alnum; - function Is_Blank (V: in Item_Type) return Standard.Boolean is + function Is_Blank (V: in Item_Type) return Boolean is begin return V = SP or else V = HT; end Is_Blank; - function Is_Cntrl (V: in Item_Type) return Standard.Boolean is + function Is_Cntrl (V: in Item_Type) return Boolean is begin return UC.Get_Category(Item_Type'Pos(V)) = UC.Cc; end Is_Cntrl; - function Is_Digit (V: in Item_Type) return Standard.Boolean is + function Is_Digit (V: in Item_Type) return Boolean is begin return UC.Is_UTF_32_Digit(Item_Type'Pos(V)); end Is_Digit; - function Is_Graph (V: in Item_Type) return Standard.Boolean is + function Is_Graph (V: in Item_Type) return Boolean is begin return Is_Print(V) and then V /= SP; end Is_Graph; - function Is_Lower (V: in Item_Type) return Standard.Boolean is + function Is_Lower (V: in Item_Type) return Boolean is begin return UC.Get_Category(Item_Type'Pos(V)) = UC.Ll; end Is_Lower; - function Is_Print (V: in Item_Type) return Standard.Boolean is + function Is_Print (V: in Item_Type) return Boolean is begin return not UC.IS_UTF_32_Non_Graphic(Item_Type'Pos(V)); end Is_Print; - function Is_Punct (V: in Item_Type) return Standard.Boolean is + function Is_Punct (V: in Item_Type) return Boolean is begin --return UC.Is_UTF_32_Punctuation(Item_Type'Pos(V)); return Is_Print(V) and then not Is_Space(V) and then not Is_Alnum(V); end Is_Punct; - function Is_Space (V: in Item_Type) return Standard.Boolean is + function Is_Space (V: in Item_Type) return Boolean is begin return UC.Is_UTF_32_Space(Item_Type'Pos(V)) or else - UC.Is_UTF_32_Line_Terminator(Item_Type'Pos(V)) or else + UC.Is_UTF_32_Line_Terminator(Item_Type'Pos(V)) or else V = HT; end Is_Space; - function Is_Upper (V: in Item_Type) return Standard.Boolean is + function Is_Upper (V: in Item_Type) return Boolean is begin return UC.Get_Category(Item_Type'Pos(V)) = UC.Lu; end Is_Upper; - function Is_Xdigit (V: in Item_Type) return Standard.Boolean is + function Is_Xdigit (V: in Item_Type) return Boolean is begin return UC.Is_UTF_32_Digit(Item_Type'Pos(V)) or else - Item_Type'Pos(V) in Standard.Character'Pos('A') .. Standard.Character'Pos('F') or else - Item_Type'Pos(V) in Standard.Character'Pos('a') .. Standard.Character'Pos('f'); + Item_Type'Pos(V) in System_Character'Pos('A') .. System_Character'Pos('F') or else + Item_Type'Pos(V) in System_Character'Pos('a') .. System_Character'Pos('f'); end Is_Xdigit; function To_Lower (V: in Item_Type) return Item_Type is @@ -84,7 +84,7 @@ package body H3.CC is return Item_Type'Val(UC.UTF_32_To_Upper_Case(Item_Type'Pos(V))); end To_Upper; - function Is_Class (V: in Item_Type; Cls: in Class) return Standard.Boolean is + function Is_Class (V: in Item_Type; Cls: in Class) return Boolean is begin case Cls is when ALPHA => return Is_Alpha(V); @@ -101,4 +101,11 @@ package body H3.CC is when XDIGIT => return Is_Xdigit(V); end case; end Is_Class; + + function Is_Code (V: in Item_Type; Code: in Item_Code) return Boolean is + begin + -- a clumsy way to work around strong type checking + -- with unknown Item_Type at the generic level? + return Item_Type'Pos(V) = Code; + end Is_Code; end H3.CC; \ No newline at end of file diff --git a/lib2/h3-cc.ads b/lib2/h3-cc.ads index a674d11..c2aad1f 100644 --- a/lib2/h3-cc.ads +++ b/lib2/h3-cc.ads @@ -1,26 +1,38 @@ -generic +generic type Item_Type is (<>); -- any discrete type package H3.CC is -- -like character classification package -- unicode-based. no system locale honored. + subtype Item_Code is H3.Natural; + + Colon: constant Item_Code := System_Character'Pos(':'); + SemicoloN: constant Item_Code := System_Character'Pos(';'); + Tilde: constant Item_Code := System_Character'Pos('~'); + Underline: constant Item_Code := System_Character'Pos('_'); + Equal: constant Item_Code := System_Character'Pos('='); + L_Arrow: constant Item_Code := System_Character'Pos('<'); + R_Arrow: constant Item_Code := System_Character'Pos('>'); + type Class is (ALPHA, ALNUM, BLANK, CNTRL, DIGIT, GRAPH, LOWER, PRINT, PUNCT, SPACE, UPPER, XDIGIT); - function Is_Class (V: in Item_Type; Cls: in Class) return Standard.Boolean; + function Is_Class (V: in Item_Type; Cls: in Class) return Boolean; - function Is_Alpha (V: in Item_Type) return Standard.Boolean; - function Is_Alnum (V: in Item_Type) return Standard.Boolean; - function Is_Blank (V: in Item_Type) return Standard.Boolean; - function Is_Cntrl (V: in Item_Type) return Standard.Boolean; - function Is_Digit (V: in Item_Type) return Standard.Boolean; - function Is_Graph (V: in Item_Type) return Standard.Boolean; - function Is_Print (V: in Item_Type) return Standard.Boolean; - function Is_Punct (V: in Item_Type) return Standard.Boolean; - function Is_Space (V: in Item_Type) return Standard.Boolean; - function Is_Xdigit (V: in Item_Type) return Standard.Boolean; + function Is_Alpha (V: in Item_Type) return Boolean; + function Is_Alnum (V: in Item_Type) return Boolean; + function Is_Blank (V: in Item_Type) return Boolean; + function Is_Cntrl (V: in Item_Type) return Boolean; + function Is_Digit (V: in Item_Type) return Boolean; + function Is_Graph (V: in Item_Type) return Boolean; + function Is_Print (V: in Item_Type) return Boolean; + function Is_Punct (V: in Item_Type) return Boolean; + function Is_Space (V: in Item_Type) return Boolean; + function Is_Xdigit (V: in Item_Type) return Boolean; - function Is_Lower (V: in Item_Type) return Standard.Boolean; - function Is_Upper (V: in Item_Type) return Standard.Boolean; + function Is_Lower (V: in Item_Type) return Boolean; + function Is_Upper (V: in Item_Type) return Boolean; function To_Lower (V: in Item_Type) return Item_Type; function To_Upper (V: in Item_Type) return Item_Type; + + function Is_Code (V: in Item_Type; Code: in Item_Code) return Boolean; end H3.CC; \ No newline at end of file diff --git a/lib2/h3-mm.adb b/lib2/h3-mm.adb index 4d17d8a..927f3bb 100644 --- a/lib2/h3-mm.adb +++ b/lib2/h3-mm.adb @@ -24,7 +24,7 @@ package body H3.MM is end if; end Get_Item_Pointer; - function Is_Shared (R: in Ref_Counted) return Standard.Boolean is + function Is_Shared (R: in Ref_Counted) return Boolean is begin --return R.Data /= null and then not System.Atomic_Counters.Is_One(R.Data.Refs); return R.Data /= null and then R.Data.Refs > 1; diff --git a/lib2/h3-mm.ads b/lib2/h3-mm.ads index d46bb37..d062795 100644 --- a/lib2/h3-mm.ads +++ b/lib2/h3-mm.ads @@ -24,7 +24,7 @@ package H3.MM is function Get_Item_Pointer (R: in Ref_Counted) return Item_Pointer; pragma Inline(Get_Item_Pointer); - function Is_Shared (R: in Ref_Counted) return Standard.Boolean; + function Is_Shared (R: in Ref_Counted) return Boolean; pragma Inline(Is_Shared); overriding procedure Initialize (R: in out Ref_Counted); diff --git a/lib2/h3-strings.ads b/lib2/h3-strings.ads index 5ed7288..3ddbbbe 100644 --- a/lib2/h3-strings.ads +++ b/lib2/h3-strings.ads @@ -2,10 +2,9 @@ with H3.Arrays; generic type Item_Type is (<>); - G_Terminator_Value: Item_Type; package H3.Strings is - package P is new H3.Arrays(Item_Type, 1, G_Terminator_Value); + package P is new H3.Arrays(Item_Type, 1, Item_Type'First); Terminator_Length: System_Zero_Or_One renames P.Terminator_Length; Terminator_Value: Item_Type renames P.Terminator_Value; diff --git a/lib2/h3.ads b/lib2/h3.ads index 3b343ec..4d8da1f 100644 --- a/lib2/h3.ads +++ b/lib2/h3.ads @@ -1,9 +1,13 @@ with System; with System.Storage_Pools; -with Ada.Finalization; package H3 is - --pragma Preelaborate (H2); + --pragma Preelaborate (H3); + subtype Boolean is Standard.Boolean; + subtype Natural is Standard.Natural; + + subtype System_Character is Standard.Wide_Character; + System_Byte_Bits: constant := System.Storage_Unit; System_Word_Bits: constant := System.Word_Size; System_Word_Bytes: constant := System_Word_Bits / System_Byte_Bits; diff --git a/lib2/hello.adb b/lib2/hello.adb index 142b1d6..5434d1d 100644 --- a/lib2/hello.adb +++ b/lib2/hello.adb @@ -15,7 +15,7 @@ with Ada.Assertions; use type H3.System_Size; procedure hello is - package S is new H3.Strings(Standard.Wide_Character, Wide_Character'Val(0)); + package S is new H3.Strings(Standard.Wide_Character); --type Global_Pool is new System.Storage_Pools.Root_Storage_Pool with null record; diff --git a/lib2/hello2.adb b/lib2/hello2.adb index 91fd479..d33ba7c 100644 --- a/lib2/hello2.adb +++ b/lib2/hello2.adb @@ -11,8 +11,8 @@ with System; use type H3.System_Size; procedure hello2 is - package A is new H3.Arrays(Standard.Wide_Character, 1, Wide_Character'Val(0)); - package S is new H3.Strings(Standard.Wide_Character, Wide_Character'Val(0)); + package A is new H3.Arrays(Standard.Wide_Character, 1, Wide_Character'First); + package S is new H3.Strings(Standard.Wide_Character); package CC is new H3.CC(Standard.Wide_Character); package C renames Interfaces.C;