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:
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

26
lib2/h3-arrays.adb
View File

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

13
lib2/h3-arrays.ads
View File

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

39
lib2/h3-cc.adb
View File

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

40
lib2/h3-cc.ads
View File

@ -1,26 +1,38 @@
generic
generic
type Item_Type is (<>); -- any discrete type
package H3.CC is
-- <ctype.h>-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;

2
lib2/h3-mm.adb
View File

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

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

3
lib2/h3-strings.ads
View File

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

8
lib2/h3.ads
View File

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

2
lib2/hello.adb
View File

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

4
lib2/hello2.adb
View File

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