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

Is_Code in H3.CC.

Browse Source 
Use Wide_Character'First instead of Wide_Character'Val(0) 
Removed the terminator parameter in the H3.Strings
This commit is contained in:
hyung-hwan 2021-10-27 15:34:30 +00:00
parent d9f957300e
commit ef734a5bc1
11 changed files with 95 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
lib2/Makefile
View File

@ -1,3 +1,14 @@
all: OPTS := -gnata -gnatW8 -gnatwa -gnatya -gnatyb -gnatyk -gnatyn -gnatyp ##-gnatyt
gnat make -gnata -gnatW8 hello && valgrind ./hello all: hello hello2 hello3
gnat make -gnata -gnatW8 hello2 && valgrind ./hello2
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

16
lib2/h3-arrays.adb
View File

@ -52,12 +52,12 @@ package body H3.Arrays is
return P; return P;
end Get_Slot_Pointer; 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 begin
return Obj.Buffer /= Empty_Buffer'Access and then Obj.Buffer.Refs > 1; return Obj.Buffer /= Empty_Buffer'Access and then Obj.Buffer.Refs > 1;
end Is_Shared; end Is_Shared;
procedure Ref_Buffer (Buf: in out Buffer_Pointer) is procedure Ref_Buffer (Buf: in Buffer_Pointer) is
begin begin
if Buf /= Empty_Buffer'Access then if Buf /= Empty_Buffer'Access then
Buf.Refs := Buf.Refs + 1; Buf.Refs := Buf.Refs + 1;
@ -162,7 +162,7 @@ package body H3.Arrays is
-- it will end up in an exception. -- it will end up in an exception.
if Shift_Dir = DIRECTION_BACKWARD then if Shift_Dir = DIRECTION_BACKWARD then
declare declare
Mid: System_Size := Shift_Pos - Shift_Size; Mid: constant System_Size := Shift_Pos - Shift_Size;
begin begin
Obj.Buffer.Slot(First .. Mid) := Tmp.Buffer.Slot(First .. Mid); 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); Obj.Buffer.Slot(Mid + 1 .. Last - Shift_Size + Terminator_Length) := Tmp.Buffer.Slot(Shift_Pos + 1 .. Last + Terminator_Length);
@ -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 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_Pos: System_Index := Pos;
Act_Inc: System_Size := Repeat; Act_Inc: constant System_Size := Repeat;
begin begin
if Act_Pos > Obj.Buffer.Last then if Act_Pos > Obj.Buffer.Last then
Act_Pos := Obj.Buffer.Last + 1; Act_Pos := Obj.Buffer.Last + 1;
@ -295,7 +295,7 @@ package body H3.Arrays is
end if; end if;
end Delete; 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; Act_Start_Pos: System_Index := Start_Pos;
begin begin
if Find_Dir = DIRECTION_FORWARD then if Find_Dir = DIRECTION_FORWARD then
@ -321,7 +321,7 @@ package body H3.Arrays is
return System_Size'First; return System_Size'First;
end Find; 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; End_Pos: System_Size;
begin begin
if Get_Length(Obj) > 0 and then V'Length > 0 and then V'Length <= Get_Length(Obj) then 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; return System_Size'First;
end Find; 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 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)); 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 "="; 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 begin
return Obj.Buffer.Slot(Get_First_Index(Obj) .. Get_Last_Index(Obj)) = Obj2; return Obj.Buffer.Slot(Get_First_Index(Obj) .. Get_Last_Index(Obj)) = Obj2;
end "="; end "=";

11
lib2/h3-arrays.ads
View File

@ -13,6 +13,7 @@ package H3.Arrays is
type Direction is (DIRECTION_BACKWARD, DIRECTION_FORWARD); type Direction is (DIRECTION_BACKWARD, DIRECTION_FORWARD);
type Elastic_Array is tagged private; 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 is array(System_Index range <>) of Item_Type;
--type Item_Array_Pointer is access all Item_Array; --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; function Get_Slot_Pointer (Obj: in Elastic_Array) return Thin_Item_Array_Pointer;
pragma Inline (Get_Slot_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); pragma Inline (Is_Shared);
procedure Clear (Obj: in out Elastic_Array); procedure Clear (Obj: in out Elastic_Array);
@ -62,11 +63,11 @@ package H3.Arrays is
procedure Delete (Obj: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size); 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_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_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 Elastic_Array) return Boolean;
function "=" (Obj: in Elastic_Array; Obj2: in Item_Array) return Standard.Boolean; function "=" (Obj: in Elastic_Array; Obj2: in Item_Array) return Boolean;
private private
type Buffer_Record(Capa: System_Size) is limited record type Buffer_Record(Capa: System_Size) is limited record

37
lib2/h3-cc.adb
View File

@ -8,70 +8,70 @@ package body H3.CC is
SP: constant Item_Type := Item_Type'Val(32); SP: constant Item_Type := Item_Type'Val(32);
HT: constant Item_Type := Item_Type'Val(9); 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 begin
return UC.Is_UTF_32_Letter(Item_Type'Pos(V)); return UC.Is_UTF_32_Letter(Item_Type'Pos(V));
end Is_Alpha; 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 begin
return UC.Is_UTF_32_Letter(Item_Type'Pos(V)) or else return UC.Is_UTF_32_Letter(Item_Type'Pos(V)) or else
UC.Is_UTF_32_Digit(Item_Type'Pos(V)); UC.Is_UTF_32_Digit(Item_Type'Pos(V));
end Is_Alnum; 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 begin
return V = SP or else V = HT; return V = SP or else V = HT;
end Is_Blank; 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 begin
return UC.Get_Category(Item_Type'Pos(V)) = UC.Cc; return UC.Get_Category(Item_Type'Pos(V)) = UC.Cc;
end Is_Cntrl; 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 begin
return UC.Is_UTF_32_Digit(Item_Type'Pos(V)); return UC.Is_UTF_32_Digit(Item_Type'Pos(V));
end Is_Digit; 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 begin
return Is_Print(V) and then V /= SP; return Is_Print(V) and then V /= SP;
end Is_Graph; 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 begin
return UC.Get_Category(Item_Type'Pos(V)) = UC.Ll; return UC.Get_Category(Item_Type'Pos(V)) = UC.Ll;
end Is_Lower; 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 begin
return not UC.IS_UTF_32_Non_Graphic(Item_Type'Pos(V)); return not UC.IS_UTF_32_Non_Graphic(Item_Type'Pos(V));
end Is_Print; 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 begin
--return UC.Is_UTF_32_Punctuation(Item_Type'Pos(V)); --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); return Is_Print(V) and then not Is_Space(V) and then not Is_Alnum(V);
end Is_Punct; 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 begin
return UC.Is_UTF_32_Space(Item_Type'Pos(V)) or else 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; V = HT;
end Is_Space; 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 begin
return UC.Get_Category(Item_Type'Pos(V)) = UC.Lu; return UC.Get_Category(Item_Type'Pos(V)) = UC.Lu;
end Is_Upper; 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 begin
return UC.Is_UTF_32_Digit(Item_Type'Pos(V)) or else 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 System_Character'Pos('A') .. System_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');
end Is_Xdigit; end Is_Xdigit;
function To_Lower (V: in Item_Type) return Item_Type is 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))); return Item_Type'Val(UC.UTF_32_To_Upper_Case(Item_Type'Pos(V)));
end To_Upper; 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 begin
case Cls is case Cls is
when ALPHA => return Is_Alpha(V); when ALPHA => return Is_Alpha(V);
@ -101,4 +101,11 @@ package body H3.CC is
when XDIGIT => return Is_Xdigit(V); when XDIGIT => return Is_Xdigit(V);
end case; end case;
end Is_Class; 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; end H3.CC;

38
lib2/h3-cc.ads
View File

@ -4,23 +4,35 @@ package H3.CC is
-- <ctype.h>-like character classification package -- <ctype.h>-like character classification package
-- unicode-based. no system locale honored. -- 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); 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_Alpha (V: in Item_Type) return Boolean;
function Is_Alnum (V: in Item_Type) return Standard.Boolean; function Is_Alnum (V: in Item_Type) return Boolean;
function Is_Blank (V: in Item_Type) return Standard.Boolean; function Is_Blank (V: in Item_Type) return Boolean;
function Is_Cntrl (V: in Item_Type) return Standard.Boolean; function Is_Cntrl (V: in Item_Type) return Boolean;
function Is_Digit (V: in Item_Type) return Standard.Boolean; function Is_Digit (V: in Item_Type) return Boolean;
function Is_Graph (V: in Item_Type) return Standard.Boolean; function Is_Graph (V: in Item_Type) return Boolean;
function Is_Print (V: in Item_Type) return Standard.Boolean; function Is_Print (V: in Item_Type) return Boolean;
function Is_Punct (V: in Item_Type) return Standard.Boolean; function Is_Punct (V: in Item_Type) return Boolean;
function Is_Space (V: in Item_Type) return Standard.Boolean; function Is_Space (V: in Item_Type) return Boolean;
function Is_Xdigit (V: in Item_Type) return Standard.Boolean; function Is_Xdigit (V: in Item_Type) return Boolean;
function Is_Lower (V: in Item_Type) return Standard.Boolean; function Is_Lower (V: in Item_Type) return Boolean;
function Is_Upper (V: in Item_Type) return Standard.Boolean; function Is_Upper (V: in Item_Type) return Boolean;
function To_Lower (V: in Item_Type) return Item_Type; function To_Lower (V: in Item_Type) return Item_Type;
function To_Upper (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; end H3.CC;

2
lib2/h3-mm.adb
View File

@ -24,7 +24,7 @@ package body H3.MM is
end if; end if;
end Get_Item_Pointer; 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 begin
--return R.Data /= null and then not System.Atomic_Counters.Is_One(R.Data.Refs); --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; return R.Data /= null and then R.Data.Refs > 1;

2
lib2/h3-mm.ads
View File

@ -24,7 +24,7 @@ package H3.MM is
function Get_Item_Pointer (R: in Ref_Counted) return Item_Pointer; function Get_Item_Pointer (R: in Ref_Counted) return Item_Pointer;
pragma Inline(Get_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); pragma Inline(Is_Shared);
overriding procedure Initialize (R: in out Ref_Counted); overriding procedure Initialize (R: in out Ref_Counted);

3
lib2/h3-strings.ads
View File

@ -2,10 +2,9 @@ with H3.Arrays;
generic generic
type Item_Type is (<>); type Item_Type is (<>);
G_Terminator_Value: Item_Type;
package H3.Strings is 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_Length: System_Zero_Or_One renames P.Terminator_Length;
Terminator_Value: Item_Type renames P.Terminator_Value; Terminator_Value: Item_Type renames P.Terminator_Value;

8
lib2/h3.ads
View File

@ -1,9 +1,13 @@
with System; with System;
with System.Storage_Pools; with System.Storage_Pools;
with Ada.Finalization;
package H3 is 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_Byte_Bits: constant := System.Storage_Unit;
System_Word_Bits: constant := System.Word_Size; System_Word_Bits: constant := System.Word_Size;
System_Word_Bytes: constant := System_Word_Bits / System_Byte_Bits; System_Word_Bytes: constant := System_Word_Bits / System_Byte_Bits;

2
lib2/hello.adb
View File

@ -15,7 +15,7 @@ with Ada.Assertions;
use type H3.System_Size; use type H3.System_Size;
procedure hello is 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; --type Global_Pool is new System.Storage_Pools.Root_Storage_Pool with null record;

4
lib2/hello2.adb
View File

@ -11,8 +11,8 @@ with System;
use type H3.System_Size; use type H3.System_Size;
procedure hello2 is procedure hello2 is
package A is new H3.Arrays(Standard.Wide_Character, 1, 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, Wide_Character'Val(0)); package S is new H3.Strings(Standard.Wide_Character);
package CC is new H3.CC(Standard.Wide_Character); package CC is new H3.CC(Standard.Wide_Character);
package C renames Interfaces.C; package C renames Interfaces.C;