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

some ada experiments...

Browse Source
This commit is contained in:
hyung-hwan 2022-08-23 10:13:02 +00:00
parent 3f9d6d9e59
commit 695c55d8a7
17 changed files with 398 additions and 661 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib2/Makefile
View File

@ -1,4 +1,4 @@
OPTS := -gnata -gnatW8 -gnatwa -gnatya -gnatyb -gnatyk -gnatyn -gnatyp -gnat05 ##-gnatyt OPTS := -gnata -gnatW8 -gnatwa -gnatya -gnatyb -gnatyk -gnatyn -gnatyp -gnat2005 ##-gnatyt
all: hello hello2 hello3 all: hello hello2 hello3
hello: hello.adb hello: hello.adb

14
lib2/h3-arrays.adb
View File

@ -3,6 +3,18 @@ with Ada.Unchecked_Deallocation;
package body H3.Arrays is package body H3.Arrays is
BUFFER_ALIGN: constant := 128; -- TODO: change it to a reasonably large value. BUFFER_ALIGN: constant := 128; -- TODO: change it to a reasonably large value.
function Get_Terminator_Length (Obj: in Elastic_Array) return System_Zero_Or_One is
begin
-- Obj unused
return Terminator_Length;
end Get_Terminator_Length;
function Get_Terminator_Value (Obj: in Elastic_Array) return Item_Type is
begin
-- Obj unused
return Terminator_Value;
end Get_Terminator_Value;
function To_Item_Array (Obj: in Elastic_Array) return Item_Array is function To_Item_Array (Obj: in Elastic_Array) return Item_Array is
begin begin
return Obj.Buffer.Slot(Obj.Buffer.Slot'First .. Obj.Buffer.Last); return Obj.Buffer.Slot(Obj.Buffer.Slot'First .. Obj.Buffer.Last);
@ -362,7 +374,7 @@ package body H3.Arrays is
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------
procedure Initialize (Obj: in out Elastic_Array) is procedure Initialize (Obj: in out Elastic_Array) is
begin begin
-- the Array is initialized to the empty buffer all the time. -- the Buffer is initialized to Empty_Buffer all the time.
-- there is no need to reference the buffer. -- there is no need to reference the buffer.
null; null;
end Initialize; end Initialize;

26
lib2/h3-arrays.ads
View File

@ -1,18 +1,20 @@
with Ada.Finalization; with Ada.Finalization;
with H3.Storage;
generic generic
--type Item_Type is private; type Item_Type is private; -- any limited definite type
type Item_Type is (<>); --type Item_Type is (<>); -- any discrete type
G_Terminator_Length: System_Zero_Or_One;
G_Terminator_Value: Item_Type; Terminator_Length: in System_Zero_Or_One;
Terminator_Value: in Item_Type;
with package Storage_Pool_Box is new H3.Storage.Pool_Box(<>);
package H3.Arrays is package H3.Arrays is
--pragma Preelaborate (Arrays); --pragma Preelaborate (Arrays);
subtype Item is Item_Type; subtype Item is Item_Type;
Terminator_Length: constant System_Zero_Or_One := G_Terminator_Length;
Terminator_Value: constant Item_Type := G_Terminator_Value;
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;
@ -23,6 +25,12 @@ package H3.Arrays is
subtype Thin_Item_Array is Item_Array(System_Index'Range); subtype Thin_Item_Array is Item_Array(System_Index'Range);
type Thin_Item_Array_Pointer is access Thin_Item_Array; type Thin_Item_Array_Pointer is access Thin_Item_Array;
function Get_Terminator_Length(Obj: in Elastic_Array) return System_Zero_Or_One;
pragma Inline (Get_Terminator_Length);
function Get_Terminator_Value(Obj: in Elastic_Array) return Item_Type;
pragma Inline (Get_Terminator_Value);
function To_Item_Array (Obj: in Elastic_Array) return Item_Array; function To_Item_Array (Obj: in Elastic_Array) return Item_Array;
function Get_Capacity (Obj: in Elastic_Array) return System_Size; function Get_Capacity (Obj: in Elastic_Array) return System_Size;
@ -83,10 +91,10 @@ private
end record; end record;
type Buffer_Pointer is access all Buffer_Record; type Buffer_Pointer is access all Buffer_Record;
--for Buffer_Pointer'Storage_Pool use <<TODO: custom storage pool?>> H3'Storage_Pool; for Buffer_Pointer'Storage_Pool use Storage_Pool_Box.Storage_Pool;
--Empty_Buffer: aliased Buffer_Record(1); --Empty_Buffer: aliased Buffer_Record(1);
-- Use 1 slot to hold the terminator value regardless of th terminator length in Empty_Buffer. -- Use 1 slot to hold the terminator value regardless of the terminator length in Empty_Buffer.
Empty_Buffer: aliased Buffer_Record := (Capa => 1, Refs => 0, Slot => (1 => Terminator_Value), Last => 0); Empty_Buffer: aliased Buffer_Record := (Capa => 1, Refs => 0, Slot => (1 => Terminator_Value), Last => 0);
type Elastic_Array is new Ada.Finalization.Controlled with record type Elastic_Array is new Ada.Finalization.Controlled with record

681
lib2/h3-compilers.adb
View File

@ -36,326 +36,10 @@ package body H3.Compilers is
end if; end if;
end Dump_Rune; end Dump_Rune;
-- ------------------------------------------------------------------- function Is_Line_Break(Code: in R.Code) return Boolean is
procedure Start_Token (C: in out Compiler) is
begin begin
C.Tk.Id := TK_EOF; -- indicate the token id is not set yet return R.Is_Rune(Code, R.V.LF); -- TODO: consider different line end convention
-- TODO: store token location. end Is_Line_Break;
S.Clear (C.Tk.Buf);
end Start_Token;
procedure Start_Token (C: in out Compiler; Ch: in R.Rune) is
begin
Start_Token (C);
S.Append (C.Tk.Buf, Ch);
end Start_Token;
procedure Start_Token (C: in out Compiler; Code: in R.Code) is
begin
Start_Token (C, R.To_Rune(Code));
end Start_Token;
procedure Start_Token (C: in out Compiler; Str: in S.Rune_Array) is
begin
Start_Token (C);
S.Append (C.Tk.Buf, Str);
end Start_Token;
procedure Feed_Token (C: in out Compiler; Ch: in R.Rune) is
begin
S.Append (C.Tk.Buf, Ch);
end Feed_Token;
procedure Feed_Token (C: in out Compiler; Code: in R.Code) is
begin
Feed_Token(C, R.To_Rune(Code));
end Feed_Token;
procedure Set_Lexer_State (C: in out Compiler; State: in Lexer_State) is
begin
C.Lx.State := State;
Start_Token (C); -- empty the token buffer
end Set_Lexer_State;
procedure Switch_Lexer_State (C: in out Compiler; State: in Lexer_State) is
begin
C.Lx.State := State;
-- don't reset the token buffer;
end Switch_Lexer_State;
procedure Set_Lexer_State (C: in out Compiler; State: in Lexer_State; Ch: in R.Rune) is
begin
-- change the lexer state while storing the first character in the token buffer.
C.Lx.State := State;
Start_Token (C, Ch);
end Set_Lexer_State;
procedure Set_Lexer_State (C: in out Compiler; State: in Lexer_State; Code: in R.Code) is
begin
Set_Lexer_State (C, State, R.To_Rune(Code));
end Set_Lexer_State;
procedure Got_Token (C: in out Compiler); -- defined further down
procedure End_Token (C: in out Compiler; Id: in Token_Id) is
begin
C.Tk.Id := Id;
Got_Token (C);
Set_Lexer_State (C, LX_START);
end End_Token;
procedure End_Token (C: in out Compiler; Id: in Token_Id; Ch: in R.Rune) is
begin
S.Append (C.Tk.Buf, Ch);
C.Tk.Id := Id;
Got_Token (C);
Set_Lexer_State (C, LX_START);
end End_Token;
procedure End_Token (C: in out Compiler; Id: in Token_Id; Code: in R.Code) is
begin
End_Token (C, Id, R.To_Rune(Code));
end End_Token;
-- -------------------------------------------------------------------
procedure Set_Parse_State (C: in out Compiler; Code: in Parse_State_Code) is
begin
C.Prs.States(C.Prs.Top).Current := Code;
end Set_Parse_State;
procedure Push_Parse_State (C: in out Compiler; Code: in Parse_State_Code) is
Top: System_Index;
begin
if C.Prs.Top = C.Prs.States'Last then
raise Syntax_Error with "parse state stack exhausted";
end if;
Top := C.Prs.Top + 1;
declare
S: Parse_State renames C.Prs.States(Top);
begin
S.Current := Code;
end;
C.Prs.Top := Top;
--ada.text_io.put_line ("Push_Parse_State " & Code'Img);
end Push_Parse_State;
procedure Pop_Parse_State (C: in out Compiler) is
begin
--ada.text_io.put_line ("Pop_Parse_State " & C.Prs.States(C.Prs.Top).Current'Img);
C.Prs.Top := C.Prs.Top - 1;
end Pop_Parse_State;
-- -------------------------------------------------------------------
procedure Push_Inclusion (C: in out Compiler; Name: in S.Rune_Array) is
Top: System_Index;
begin
if C.Inc.Top = C.Inc.Streams'Last then
raise Syntax_Error with "inclusion depth too deep";
end if;
Top := C.Inc.Top + 1;
declare
S: Stream renames C.Inc.Streams(Top);
begin
Ada.Text_IO.Open (S.Handle, Ada.Text_IO.In_File, Standard.String(Utf8.From_Unicode_String(Name)));
S.Prs_Level := C.Prs.Top; -- this is the parse state level of this include directive.
end;
C.Inc.Top := Top;
-- Switch the parse state to handle the terminator
-- after the new pushed state has been popped out.
Set_Parse_State (C, PS_INCLUDE_TERMINATOR);
-- Let the inner content be handled at the state as the include directive is seen.
Push_Parse_State (C, C.Prs.States(C.Prs.Top - 1).Current);
end Push_Inclusion;
procedure Pop_Inclusion (C: in out Compiler; Check: in Boolean) is
begin
Ada.Text_IO.Close (C.Inc.Streams(C.Inc.Top).Handle);
if Check then
if C.Prs.Top /= C.Inc.Streams(C.Inc.Top).Prs_Level + 1 then
ada.text_io.put_line (">>>>>>>>>>> UNBALANCED INCLUSION CONTEXT..." & C.Prs.Top'Img & " " & C.Inc.Streams(C.Inc.Top).Prs_Level'Img);
raise Syntax_Error with "unbalanced inclusion content";
end if;
end if;
C.Inc.Top := C.Inc.Top - 1;
Pop_Parse_State (C);
end Pop_Inclusion;
-- -------------------------------------------------------------------
procedure Parse_Ident (C: in out Compiler) is
begin
if C.Tk.Buf.Equals(LB_CLASS) then
Push_Parse_State (C, PS_CLASS_1);
elsif C.Tk.Buf.Equals(LB_FUN) then
Push_Parse_State (C, PS_FUN_1);
else
-- probably a command name or a variable name?
Push_Parse_State (C, PS_PLAIN_STATEMENT_START);
C.Prs.States(C.Prs.Top).Data := (
Code => PD_STATEMENT,
Stmt_Starter => C.Tk.Buf
);
end if;
end Parse_Ident;
procedure Parse_Class_1 (C: in out Compiler) is
begin
null;
end Parse_Class_1;
procedure Parse_Class_2 (C: in out Compiler) is
begin
null;
end Parse_Class_2;
-- -------------------------------------------------------------------
procedure Parse_Plain_Statement_Start (C: in out Compiler) is
begin
case C.Tk.Id is
when TK_EOL =>
Pop_Parse_State (C);
when TK_EOF =>
Pop_Parse_State (C);
if C.Inc.Top > 0 then
Pop_Inclusion (C, True);
else
-- end of really the input??
null;
end if;
when TK_CSTR =>
null;
when TK_IDENT =>
null;
when TK_DOLLARED_LPAREN => -- $(
Push_Parse_State (C, PS_START);
when TK_RPAREN =>
Pop_Parse_State (C); -- pop as if EOL is seen.
Pop_Parse_State (C); -- pop against TK_DOLLARED_LPAREN
when TK_SEMICOLON =>
-- end of the current statement. go on to the next statement
Set_Parse_State (C, PS_PLAIN_STATEMENT_START);
when others =>
raise Syntax_Error with "invalid token in in plain statement";
end case;
end Parse_Plain_Statement_Start;
-- -------------------------------------------------------------------
procedure Parse_Start (C: in out Compiler) is
begin
case C.Tk.Id is
when TK_BSTR =>
null;
when TK_BYTE =>
null;
when TK_CHAR =>
null;
when TK_CSTR =>
null;
when TK_DIRECTIVE =>
if C.Tk.Buf.Equals(LB_XINCLUDE) then
--Set_Parse_State (C, PS_INCLUDE_TARGET);
Push_Parse_State (C, PS_INCLUDE_TARGET);
else
raise Syntax_Error with "unknown directive name";
end if;
when TK_EOF =>
if C.Inc.Top > 0 then
Pop_Inclusion (C, True);
else
-- end of really the input??
null;
end if;
when TK_EOL =>
null;
when TK_IDENT =>
Parse_Ident (C);
--when TK_NUMBER =>
-- null;
-- plus or minus signed may be allowed here too.
-- plusplus or miniusminus may be allowed here too.
when TK_SEMICOLON =>
null;
--when TK_HASHED_LBRACE =>
-- null;
--when TK_HASHED_LBRACK =>
-- null;
when TK_DOLLARED_LPAREN =>
Push_Parse_State (C, PS_START);
when TK_RPAREN =>
Pop_Parse_State (C);
when others =>
raise Syntax_Error with "unexpected token";
end case;
end Parse_Start;
procedure Parse_Include_Target (C: in out Compiler) is
begin
if C.Tk.Id = TK_CSTR then
-- arrange to feed more data from the included file.
Push_Inclusion (C, S.To_Rune_Array(C.Tk.Buf));
else
-- the target is not a string.
--Dump_Token (C.Tk);
raise Syntax_Error with "string literal required";
end if;
end Parse_Include_Target;
procedure Parse_Include_Terminator (C: in out Compiler) is
begin
if C.Tk.Id /= TK_SEMICOLON then
raise Syntax_Error with "semicolon required";
end if;
Pop_Parse_State (C);
end Parse_Include_Terminator;
procedure Got_Token (C: in out Compiler) is
begin
Dump_Token (C.Tk);
case C.Prs.States(C.Prs.Top).Current is
when PS_START =>
Parse_Start (C);
when PS_INCLUDE_TARGET =>
Parse_Include_Target (C);
when PS_INCLUDE_TERMINATOR =>
Parse_Include_Terminator (C);
when PS_PLAIN_STATEMENT_START =>
Parse_Plain_Statement_Start (C);
when others =>
raise Syntax_Error with "unknown parser state"; -- TODO: change this...
end case;
end Got_Token;
function Is_Ident_Starter(Code: in R.Code) return Boolean is function Is_Ident_Starter(Code: in R.Code) return Boolean is
begin begin
@ -369,269 +53,122 @@ ada.text_io.put_line (">>>>>>>>>>> UNBALANCED INCLUSION CONTEXT..." & C.Prs.Top'
return Is_Ident_Starter(Code); -- or else R.Is_Rune(Code, R.V.Underline); -- or else R.Is_Rune(C, ...); return Is_Ident_Starter(Code); -- or else R.Is_Rune(Code, R.V.Underline); -- or else R.Is_Rune(C, ...);
end Is_Ident_Char; end Is_Ident_Char;
procedure Feed_Char_Code (C: in out Compiler; Code: in R.Code) is -- -------------------------------------------------------------------
package body Feeder is
procedure Switch_To_Start (C: in out Compiler) is
begin
C.F.Lx.Data := Lex_Data'(State => LX_START);
end Switch_To_Start;
procedure Start (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
begin
null;
end Start;
procedure Comment (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
begin
if Is_Line_Break(Code) then
Switch_To_Start (C);
end if;
end Comment;
procedure Delim_Token (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
begin
null;
end Delim_Token;
procedure Hmarked_Token (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
begin
null;
end Hmarked_Token;
procedure Update_Location (C: in out Compiler; Code: in R.Code) is
begin
if Is_Line_Break(Code) then
C.F.Lx.Loc.Line := C.F.Lx.Loc.Line + 1;
C.F.Lx.Loc.Colm := 1;
else
C.F.Lx.Loc.Colm := C.F.Lx.Loc.Colm + 1;
end if;
end Update_Location;
procedure Begin_Include (C: in out Compiler) is
begin
null;
end Begin_Include;
procedure Feed_From_Includee (C: in out Compiler) is
begin
null;
end Feed_From_Includee;
end Feeder;
-- -------------------------------------------------------------------
procedure Feed_Char_Code (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
begin begin
<<Start_Over>> case C.F.Lx.Data.State is
--Dump_Rune (Code); when Feeder.LX_START =>
Feeder.Start(C, Code, Consumed);
case C.Lx.State is when Feeder.LX_COMMENT =>
when LX_START => Feeder.Comment(C, Code, Consumed);
if R.Is_Eof(Code) then when Feeder.LX_DT =>
Start_Token (C, LB_EOF); Feeder.Delim_Token(C, Code, Consumed);
End_Token (C, TK_EOF); when Feeder.LX_HC =>
-- this procedure doesn't prevent you from feeding more runes Feeder.Hmarked_Token(C, Code, Consumed);
-- after EOF. but it's not desirable to feed more after EOF.
elsif R.Is_Rune(Code, R.V.LF) then -- TODO: support a different EOL scheme
Start_Token (C, LB_EOL);
End_Token (C, TK_EOL);
elsif R.Is_Space(Code) then
-- ignore. carry on
null;
elsif R.Is_Rune(Code, R.V.Number_Sign) then -- #
Set_Lexer_State (C, LX_HASHED, Code);
elsif R.Is_Rune(Code, R.V.Dollar_Sign) then -- $
Set_Lexer_State (C, LX_DOLLARED, Code);
elsif R.Is_Rune(Code, R.V.Left_Curly_Bracket) then -- {
Start_Token (C, Code);
End_Token (C, TK_LBRACE);
elsif R.Is_Rune(Code, R.V.Right_Curly_Bracket) then -- }
Start_Token (C, Code);
End_Token (C, TK_RBRACE);
elsif R.Is_Rune(Code, R.V.Left_Square_Bracket) then -- [
Start_Token (C, Code);
End_Token (C, TK_LBRACK);
elsif R.Is_Rune(Code, R.V.Right_Square_Bracket) then -- ]
Start_Token (C, Code);
End_Token (C, TK_RBRACK);
elsif R.Is_Rune(Code, R.V.Left_Parenthesis) then -- (
Start_Token (C, Code);
End_Token (C, TK_LPAREN);
elsif R.Is_Rune(Code, R.V.Right_Parenthesis) then -- )
Start_Token (C, Code);
End_Token (C, TK_RPAREN);
elsif R.Is_Rune(Code, R.V.Semicolon) then -- ;
Start_Token (C, Code);
End_Token (C, TK_SEMICOLON);
elsif R.Is_Rune(Code, R.V.Colon) then -- :
Set_Lexer_State (C, LX_COLON, Code);
elsif R.Is_Rune(Code, R.V.Quotation) then -- "
Set_Lexer_State (C, LX_CSTR);
elsif Is_Ident_Starter(Code) then
Set_Lexer_State (C, LX_IDENT, Code);
elsif R.Is_Digit(Code) then
Set_Lexer_State (C, LX_NUMBER, Code);
--elsif R.Is_Rune(Code, R.V.Plus_Sign) then -- +
-- Set_Lexer_State (C, LX_OP_PLUS, Code);
--elsif R.Is_Rune(Code, R.V.Minus_Sign) then -- -
-- Set_Lexer_State (C, LX_OP_MINUS, Code);
--elsif R.Is_Rune(Code, R.V.Asterisk) then -- *
-- Set_Lexer_State (C, LX_OP_MUL, Code);
--elsif R.Is_Rune(Code, R.V.Slash) then -- /
-- Set_Lexer_State (C, LX_OP_DIV, Code);
--elsif R.Is_Rune(Code, R.V.Left_Arrow) then -- <
-- Set_Lexer_State (C, LX_OP_LESS, Code);
--elsif R.Is_Rune(Code, R.V.Right_Arrow) then -- >
-- Set_Lexer_State (C, LX_OP_GREATER, Code);
else
raise Syntax_Error;
end if;
when LX_COLON =>
if R.Is_Rune(Code, R.V.Equal_Sign) then -- :=
End_Token (C, TK_ASSIGN, Code);
else
End_Token (C, TK_COLON);
goto Start_Over;
end if;
when LX_COMMENT =>
if R.Is_Eof(Code) then
Set_Lexer_State (C, LX_START);
goto Start_Over;
elsif R.Is_Rune(Code, R.V.LF) then -- TODO: support a different EOL scheme
Start_Token (C, LB_EOL);
End_Token (C, TK_EOL);
end if;
when LX_CSTR =>
-- TODO: escaping...
if R.Is_Rune(Code, R.V.Quotation) then
End_Token (C, TK_CSTR);
else
Feed_Token (C, Code);
end if;
when LX_DIRECTIVE =>
if R.Is_Alnum(Code) or else R.Is_Rune(Code, R.V.Underline) then
Feed_Token (C, Code);
else
End_Token (C, TK_DIRECTIVE);
goto Start_Over;
end if;
when LX_DOLLARED =>
if R.Is_Rune(Code, R.V.Left_Curly_Bracket) then
End_Token (C, TK_DOLLARED_LBRACE, Code);
elsif R.Is_Rune(Code, R.V.Left_Square_Bracket) then
End_Token (C, TK_DOLLARED_LBRACK, Code);
elsif R.Is_Rune(Code, R.V.Left_Parenthesis) then
End_Token (C, TK_DOLLARED_LPAREN, Code);
else
raise Syntax_Error with "invalid dollared token";
end if;
when LX_HASHED =>
if R.Is_Alnum(Code) or else R.Is_Rune(Code, R.V.Underline) then
Feed_Token (C, Code);
Switch_Lexer_State (C, LX_DIRECTIVE);
elsif R.Is_Rune(Code, R.V.Number_Sign) or else R.Is_Rune(Code, R.V.Exclamation) then -- ## or #!
Set_Lexer_State (C, LX_COMMENT);
elsif R.Is_Rune(Code, R.V.Left_Curly_Bracket) then
End_Token (C, TK_HASHED_LBRACE, Code);
elsif R.Is_Rune(Code, R.V.Left_Square_Bracket) then
End_Token (C, TK_HASHED_LBRACK, Code);
elsif R.Is_Rune(Code, R.V.Left_Parenthesis) then
End_Token (C, TK_HASHED_LPAREN, Code);
else
raise Syntax_Error with "invalid hashed token";
end if;
when LX_IDENT =>
if Is_Ident_Char(Code) then
Feed_Token (C, Code);
else
End_Token (C, TK_IDENT);
goto Start_Over;
end if;
when LX_NUMBER =>
if R.Is_Digit(Code) then
Feed_Token (C, Code);
else
End_Token (C, TK_IDENT); -- TODO: change this
goto Start_Over;
end if;
when LX_OP_PLUS =>
if R.Is_Rune(Code, R.V.Plus_Sign) then
End_Token (C, TK_PLUSPLUS, Code);
else
End_Token (C, TK_PLUS);
goto Start_Over;
end if;
when LX_OP_MINUS =>
if R.Is_Rune(Code, R.V.Minus_Sign) then
End_Token (C, TK_MINUSMINUS, Code);
else
End_Token (C, TK_MINUS);
goto Start_Over;
end if;
when LX_OP_MUL =>
if R.Is_Rune(Code, R.V.Asterisk) then
End_Token (C, TK_MULMUL, Code);
else
End_Token (C, TK_MUL);
goto Start_Over;
end if;
when LX_OP_DIV =>
if R.Is_Rune(Code, R.V.Slash) then
End_Token (C, TK_DIVDIV, Code);
else
End_Token (C, TK_DIV);
goto Start_Over;
end if;
when LX_OP_GREATER =>
if R.Is_Rune(Code, R.V.Equal_Sign) then
End_Token (C, TK_GE, Code);
else
End_Token (C, TK_GT);
goto Start_Over;
end if;
when LX_OP_LESS =>
if R.Is_Rune(Code, R.V.Equal_sign) then
End_Token (C, TK_LE, Code);
else
End_Token (C, TK_LT);
goto Start_Over;
end if;
end case; end case;
--raise Internal_Error with "internal error - unknown flx state";
end Feed_Char_Code; end Feed_Char_Code;
procedure Feed_Inc (C: in out Compiler) is
-- Feed the contents of a included stream.
Entry_Top: constant System_Index := C.Inc.Top;
Use_Immediate: constant Boolean := True;
begin
loop
while not Ada.Text_IO.End_Of_File(C.Inc.Streams(C.Inc.Top).Handle) loop
declare
Ch: Standard.Character;
begin
-- Get() skips line terminators. End_Of_Line() checks if it reaches EOL
-- but can't handle multiple consecutive EOLs. Get_Immediate() doesn't
-- skip EOLs. As detecting every EOL in the multiple consecutive sequence
-- is not required, End_Of_Line()+Get() is good too.
if Use_Immediate then
Ada.Text_IO.Get_Immediate (C.Inc.Streams(C.Inc.Top).Handle, Ch);
else
if Ada.Text_IO.End_Of_Line(C.Inc.Streams(C.Inc.Top).Handle) then
Feed_Char_Code (C, R.P.LF);
end if;
Ada.Text_IO.Get (C.Inc.Streams(C.Inc.Top).Handle, Ch);
end if;
Feed_Char_Code (C, Standard.Character'Pos(Ch));
end;
-- After each feed, C.Inc.Top may get incremented if an inclusion
-- directive is found. so the while loop iterates over the streams
-- of all inner included levels. End_Feed() below drops C.Inc.Top
-- and the outer loop will resume the inner while loop at the outer
-- inclusion level until all entered inclusion levels are exited.
end loop;
End_Feed (C);
if C.Inc.Top < Entry_Top then
-- Pop_Inclusion() is called on EOF which is fed by End_Feed().
-- It also decrements the stack pointer. The current inclusion
-- stack pointer will get less that First_Top if the first inclusion
-- level entered is exited.
exit;
end if;
end loop;
end Feed_Inc;
procedure Feed (C: in out Compiler; Data: in S.Rune_Array) is procedure Feed (C: in out Compiler; Data: in S.Rune_Array) is
Consumed: Boolean;
CC: R.Code;
I: System_Index := Data'First;
begin begin
for i in Data'Range loop while I <= Data'Last loop
Feed_Char_Code (C, R.To_Code(Data(i))); CC := R.To_Code(Data(I));
if C.Inc.Top > 0 then Feed_Char_Code (C, CC, consumed);
Feed_Inc (C); if Consumed then
Feeder.Update_Location (C, CC);
I := I + 1;
end if; end if;
if C.F.Rd.Do_Include_File then
Feeder.Begin_Include (C);
C.F.Rd.Do_Include_File := False;
end if;
--if C->Cur then
-- Feeder.Feed_From_Includee (C);
--end if;
end loop; end loop;
end Feed; end Feed;
procedure End_Feed (C: in out Compiler) is procedure End_Feed (C: in out Compiler) is
Consumed: Boolean;
begin begin
Feed_Char_Code (C, R.P.EOF); begin
loop
Feed_Char_Code(C, R.P.EOF, Consumed);
exit when Consumed;
end loop;
exception
when others =>
--if C.Feed.Rd.Level <= 0 and then C.Get_Error_Number = HCL_ERR_SYNTAX and then C.Get_Syntax_Error_Number = HCL_SYNERR_EOF then
-- null; -- normal EOF
--else
raise;
--end if;
end;
end End_Feed; end End_Feed;
-- ------------------------------------------------------------------- -- -------------------------------------------------------------------
procedure Initialize (C: in out Compiler) is procedure Initialize (C: in out Compiler) is
begin begin
Push_Parse_State (C, PS_START); --Push_Parse_State (C, PS_START);
declare declare
X: H3.Trees.Tree; X: H3.Trees.Tree;
@ -642,11 +179,13 @@ ada.text_io.put_line (">>>>>>>>>>> UNBALANCED INCLUSION CONTEXT..." & C.Prs.Top'
procedure Finalize (C: in out Compiler) is procedure Finalize (C: in out Compiler) is
begin begin
while C.Inc.Top > 0 loop --while C.Inc.Top > 0 loop
Pop_Inclusion (C, False); -- Pop_Inclusion (C, False);
end loop; --end loop;
while C.Prs.Top > 0 loop --while C.Prs.Top > 0 loop
Pop_Parse_State (C); -- Pop_Parse_State (C);
end loop; --end loop;
null;
end Finalize; end Finalize;
end H3.Compilers; end H3.Compilers;

92
lib2/h3-compilers.ads
View File

@ -1,16 +1,19 @@
with H3.Runes; with H3.Runes;
with H3.Strings; with H3.Strings;
with H3.Storage;
with H3.Trees; with H3.Trees;
with Ada.Finalization; with Ada.Finalization;
with Ada.Text_IO; with Ada.Text_IO;
generic generic
type Rune_Type is (<>); type Rune_Type is (<>);
with package Storage_Pool_box is new H3.Storage.Pool_Box(<>);
package H3.Compilers is package H3.Compilers is
package R is new H3.Runes(Rune_Type); package R is new H3.Runes(Rune_Type);
package S is new H3.Strings(Rune_Type); package S is new H3.Strings(Rune_Type, Storage_Pool_Box);
Syntax_Error: exception; Syntax_Error: exception;
Internal_Error: exception;
--type Compiler is tagged limited private; --type Compiler is tagged limited private;
type Compiler is new Ada.Finalization.Limited_Controlled with private; type Compiler is new Ada.Finalization.Limited_Controlled with private;
@ -22,28 +25,6 @@ package H3.Compilers is
overriding procedure Finalize (C: in out Compiler); overriding procedure Finalize (C: in out Compiler);
private private
type Lexer_State is (
LX_START,
LX_COLON,
LX_COMMENT,
LX_CSTR,
LX_DIRECTIVE,
LX_DOLLARED,
LX_HASHED,
LX_IDENT,
LX_NUMBER,
LX_OP_DIV,
LX_OP_GREATER,
LX_OP_LESS,
LX_OP_MINUS,
LX_OP_MUL,
LX_OP_PLUS
);
type Lexer is record
State: Lexer_State := LX_START;
end record;
type Token_Id is ( type Token_Id is (
TK_ASSIGN, TK_ASSIGN,
TK_BSTR, TK_BSTR,
@ -86,6 +67,67 @@ private
Buf: S.Elastic_String; Buf: S.Elastic_String;
end record; end record;
-- ------------------------------------------------------------------
type Location is record
line: System_Size := 0;
colm: System_Size := 0;
-- file: S.Bounded_String_Pointer := null;
end record;
package Feeder is
type Lex_State_Code is (LX_START, LX_COMMENT, LX_DT, LX_HC);
type Lex_Data(State: Lex_State_Code := LX_START) is record
case State is
when LX_START =>
null;
when LX_COMMENT =>
null;
when LX_DT =>
Row_Start: Integer;
Row_End: Integer;
Col_NexT: Integer;
when LX_HC =>
Char_Count: System_Size;
end case;
end record;
type Lex is record
loc: Location;
oloc: Location;
data: Lex_Data;
end record;
type Read is record
level: Integer;
flagv: Integer;
expect_include_file: Boolean;
expect_vlist_item: Boolean;
do_include_file: Boolean;
-- TODO: obj: Cnode;
end record;
type Feed is record
lx: Lex;
rd: Read;
end record;
procedure Start (C: in out Compiler; Code: in R.Code; Consumed: out Boolean);
procedure Comment (C: in out Compiler; Code: in R.Code; Consumed: out Boolean);
procedure Delim_Token (C: in out Compiler; Code: in R.Code; Consumed: out Boolean);
procedure Hmarked_Token (C: in out Compiler; Code: in R.Code; Consumed: out Boolean);
procedure Update_Location (C: in out Compiler; Code: in R.Code);
procedure Begin_Include (C: in out Compiler);
procedure Feed_From_Includee (C: in out Compiler);
end Feeder;
-- ------------------------------------------------------------------
package Parser is
-- move parser types here.
end Parser;
-- ------------------------------------------------------------------ -- ------------------------------------------------------------------
type Parse_State_Code is ( type Parse_State_Code is (
@ -149,10 +191,12 @@ private
--type Compiler is tagged limited record --type Compiler is tagged limited record
type Compiler is new Ada.Finalization.Limited_Controlled with record type Compiler is new Ada.Finalization.Limited_Controlled with record
Lx: Lexer; F: Feeder.Feed;
Tk: Token; Tk: Token;
Prs: Parse_State_Stack(128); -- TODO: make this dynamic. single access type. dynamic allocation Prs: Parse_State_Stack(128); -- TODO: make this dynamic. single access type. dynamic allocation
Inc: Include_Stack(32); -- TODO: make this dynamic. single access type. dynamic allocation Inc: Include_Stack(32); -- TODO: make this dynamic. single access type. dynamic allocation
end record; end record;
end H3.Compilers; end H3.Compilers;

11
lib2/h3-cords.ads Normal file
View File

@ -0,0 +1,11 @@
with H3.Arrays;
generic
type Item_Type is private; -- any limited definite type
G_Terminator_Length: System_Zero_Or_One := 0;
G_Terminator_Value: Item_Type;
package H3.Strings is
package P is new H3.Arrays(Item_Type, G_Terminator_Length);
end H3.Cords;

21
lib2/h3-io.ads Normal file
View File

@ -0,0 +1,21 @@
generic
type Rune_Type is (<>);
with package Storage_Pool_box is new H3.Storage.Pool_Box(<>);
package H3.IO is
type Stream is abstract tagged limited null record;
procedure Open (Handle: in out Stream; ) is abstract;
procedure Close (Handle: in out Stream) is abstract;
procedure Read (Handle: in out Stream; Data: out System_Byte_Array; Last: out System_Size) is abstract;
procedure Write (Handle: in out Stream; Data: in System_Byte_Array; Last: out System_Size) is abstract;
type File_Stream is new Stream with record
Name: ...
Handle: Ada.Wide_Text_IO.File_Type;
end record;
end H3.IO;

1
lib2/h3-limited_pool.adb
View File

@ -5,7 +5,6 @@ package body H3.Limited_Pool is
function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type is function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type is
P: Storage_Pool_Pointer; P: Storage_Pool_Pointer;
begin begin
if Pool = null then if Pool = null then
P := Storage_Pool; P := Storage_Pool;

2
lib2/h3-pool.adb
View File

@ -87,7 +87,7 @@ package body H3.Pool is
Tmp: Pooled_Pointer := To_Pooled_Pointer(Target); Tmp: Pooled_Pointer := To_Pooled_Pointer(Target);
begin begin
Dealloc (Tmp); Dealloc (Tmp);
Target := null; Target := null;
end; end;
end if; end if;
end Deallocate; end Deallocate;

47
lib2/h3-storage.ads Normal file
View File

@ -0,0 +1,47 @@
with H3.Storage_Pools;
with System.Pool_Global;
package H3.Storage is
-- the H3.Storage.Pool_Box is a wrapper that binds a storage pool type
-- and an actual storage pool. Other generic packages are desinged to
-- accept this single binding package rather than a type and an object
-- separately.
--
-- generic
-- ...
-- type Storage_Pool_Type is new H3.Root_Storage_Pool with private;
-- Storage_Pool: in out Storage_Pool_Type;
-- ...
-- package ... is
--
-- <<VS>>
--
-- generic
-- ...
-- with package Storage_Pool_Box is new H3.Storage.Pool_Box(<>);
-- ...
-- package ... is
--
generic
type Storage_Pool_Type is new H3.Root_Storage_Pool with private;
Storage_Pool: in out Storage_Pool_Type; -- actual storage pool object.
package Pool_Box is
-- blank
end Pool_Box;
-- -------------------------------------------------------------
Global_Pool: H3.Storage_Pools.Global_Pool;
package Global_Pool_Box is new Pool_Box(
Storage_Pool_Type => H3.Storage_Pools.Global_Pool,
Storage_Pool => Global_Pool
);
-- -------------------------------------------------------------
package System_Pool_Box is new Pool_Box(
Storage_Pool_Type => System.Pool_Global.Unbounded_No_Reclaim_Pool,
Storage_Pool => System.Pool_Global.Global_Pool_Object
);
end H3.Storage;

17
lib2/h3-storage_pools.adb
View File

@ -1,7 +1,7 @@
with System; with System;
with System.Address_Image; with System.Address_Image;
with Ada.Text_IO; --with Ada.Text_IO;
package body H3.Storage_Pools is package body H3.Storage_Pools is
@ -20,10 +20,11 @@ package body H3.Storage_Pools is
begin begin
tmp := Sys_Malloc(System_Size(((Size + Alignment - 1) / Alignment) * Alignment)); tmp := Sys_Malloc(System_Size(((Size + Alignment - 1) / Alignment) * Alignment));
if System."="(tmp, System.Null_Address) then if System."="(tmp, System.Null_Address) then
raise Storage_Error; --raise H3.Storage_Error;
raise Standard.Storage_Error;
else else
Address := tmp; Address := tmp;
Ada.Text_IO.Put_Line ("Global_Pool Allocating Size: " & SSE.Storage_Count'Image (Size) & " Actual-Size: " & SSE.Storage_Count'Image (((Size + Alignment - 1) / Alignment) * Alignment) & "Address: " & System.Address_Image(Address)); --Ada.Text_IO.Put_Line ("Global_Pool Allocating Size: " & SSE.Storage_Count'Image (Size) & " Actual-Size: " & SSE.Storage_Count'Image (((Size + Alignment - 1) / Alignment) * Alignment) & "Address: " & System.Address_Image(Address));
end if; end if;
end Allocate; end Allocate;
@ -33,14 +34,14 @@ Ada.Text_IO.Put_Line ("Global_Pool Allocating Size: " & SSE.Storage_Count'Image
Alignment: in SSE.Storage_Count) is Alignment: in SSE.Storage_Count) is
begin begin
--Ada.Text_IO.Put_Line ("Global_Pool Deallocating Address: " & System.Address'Img); ----Ada.Text_IO.Put_Line ("Global_Pool Deallocating Address: " & System.Address'Img);
Ada.Text_IO.Put_Line ("Global_Pool Deallocating " & System.Address_Image(Address)); --Ada.Text_IO.Put_Line ("Global_Pool Deallocating " & System.Address_Image(Address));
Sys_Free (Address); Sys_Free (Address);
end Deallocate; end Deallocate;
function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count is function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count is
begin begin
Ada.Text_IO.Put_Line ("Global_Pool Storage_Size "); --Ada.Text_IO.Put_Line ("Global_Pool Storage_Size ");
return SSE.Storage_Count'Last; return SSE.Storage_Count'Last;
end Storage_Size; end Storage_Size;
@ -59,7 +60,7 @@ Ada.Text_IO.Put_Line ("Global_Pool Storage_Size ");
Size: in SSE.Storage_Count; Size: in SSE.Storage_Count;
Alignment: in SSE.Storage_Count) is Alignment: in SSE.Storage_Count) is
begin begin
ada.text_io.put_line ("system__storage_pools__allocate..."); --ada.text_io.put_line ("system__storage_pools__allocate...");
SSP.Allocate (Pool, Address, Size, Alignment); SSP.Allocate (Pool, Address, Size, Alignment);
end Allocate_315P; end Allocate_315P;
@ -67,7 +68,7 @@ ada.text_io.put_line ("system__storage_pools__allocate...");
pragma Export (Ada, Deallocate_315P, "system__storage_pools__deallocate"); pragma Export (Ada, Deallocate_315P, "system__storage_pools__deallocate");
procedure Deallocate_315P (Pool: in out SSP.Root_Storage_Pool'Class; Address : in System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count) is procedure Deallocate_315P (Pool: in out SSP.Root_Storage_Pool'Class; Address : in System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count) is
begin begin
ada.text_io.put_line ("system__storage_pools__deallocate..."); --ada.text_io.put_line ("system__storage_pools__deallocate...");
SSP.Deallocate (Pool, Address, Size, Alignment); SSP.Deallocate (Pool, Address, Size, Alignment);
end Deallocate_315P; end Deallocate_315P;

2
lib2/h3-storage_pools.ads
View File

@ -20,6 +20,8 @@ package H3.Storage_Pools is
function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count; function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count;
-- TODO: implement more pools
private private
type Global_Pool is new SSP.Root_Storage_Pool with null record; type Global_Pool is new SSP.Root_Storage_Pool with null record;

17
lib2/h3-strings.ads
View File

@ -1,17 +1,27 @@
with H3.Arrays; with H3.Arrays;
with H3.Storage;
with H3.Storage_Pools;
generic generic
type Rune_Type is (<>); type Rune_Type is (<>);
with package Storage_Pool_Box is new H3.Storage.Pool_Box(<>);
package H3.Strings is package H3.Strings is
package P is new H3.Arrays(Rune_Type, 1, Rune_Type'First); package P is new H3.Arrays(
Item_Type => Rune_Type,
Terminator_Length => 1,
Terminator_Value => Rune_Type'First,
Storage_Pool_Box => Storage_Pool_Box
);
subtype Rune is P.Item; subtype Rune is P.Item;
subtype Rune_Array is P.Item_Array; subtype Rune_Array is P.Item_Array;
subtype Thin_Rune_Array_Pointer is P.Thin_Item_Array_Pointer; subtype Thin_Rune_Array_Pointer is P.Thin_Item_Array_Pointer;
Terminator_Length: System_Zero_Or_One renames P.Terminator_Length; --Terminator_Length: System_Zero_Or_One renames P.Terminator_Length;
Terminator_Value: Rune renames P.Terminator_Value; --Terminator_Value: Rune renames P.Terminator_Value;
type Elastic_String is new P.Elastic_Array with record type Elastic_String is new P.Elastic_Array with record
--A: standard.integer := 999; --A: standard.integer := 999;
@ -24,3 +34,4 @@ package H3.Strings is
overriding procedure Append (Obj: in out Elastic_String; V: in Rune_Array); overriding procedure Append (Obj: in out Elastic_String; V: in Rune_Array);
end H3.Strings; end H3.Strings;

12
lib2/h3.ads
View File

@ -29,15 +29,21 @@ package H3 is
+(2 ** (System_Word_Bits - 1)) - 1; +(2 ** (System_Word_Bits - 1)) - 1;
for System_Signed_Word'Size use System_Word_Bits; for System_Signed_Word'Size use System_Word_Bits;
--type System_Size is new System_Word range 0 .. (2 ** System_Word_Bits) - 1; -- Don't include the max value of System_Word in System_Size.
subtype System_Size is System_Word range 0 .. (2 ** System_Word_Bits) - 1; -- It is not possible for a program to contain a single object of
-- this max value size. By keeping the last value one less than the max,
-- it prevents a value overrun issue in looping.
--type System_Size is new System_Word range 0 .. (2 ** System_Word_Bits) - 2;
subtype System_Size is System_Word range 0 .. (2 ** System_Word_Bits) - 2;
--subtype System_Index is System_Size range 0 .. (System_Size'Last - 1); --subtype System_Index is System_Size range 0 .. (System_Size'Last - 1);
subtype System_Index is System_Size range (System_Size'First + 1) .. System_Size'Last; subtype System_Index is System_Size range (System_Size'First + 1) .. System_Size'Last;
subtype System_Zero_Or_One is System_Word range 0 .. 1; subtype System_Zero_Or_One is System_Word range 0 .. 1;
type Storage_Pool_Pointer is access all System.Storage_Pools.Root_Storage_Pool'Class; subtype Root_Storage_Pool is System.Storage_Pools.Root_Storage_Pool;
type Storage_Pool_Pointer is access all Root_Storage_Pool'Class;
--Storage_Error: exception renames Standard.Storage_Error;
type System_Byte_Array is array(System_Index range<>) of System_Byte; type System_Byte_Array is array(System_Index range<>) of System_Byte;

100
lib2/hello.adb
View File

@ -2,6 +2,7 @@ with H3.Pool;
with H3.Limited_Pool; with H3.Limited_Pool;
with H3.Arrays; with H3.Arrays;
with H3.Strings; with H3.Strings;
with H3.Storage;
with H3.Storage_Pools; with H3.Storage_Pools;
with H3.MM; with H3.MM;
with GNAT.Debug_Pools; with GNAT.Debug_Pools;
@ -15,8 +16,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); package S is new H3.Strings(Standard.Wide_Character, H3.Storage.Global_Pool_Box);
--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;
P1: aliased System.Pool_Global.Unbounded_No_Reclaim_Pool; P1: aliased System.Pool_Global.Unbounded_No_Reclaim_Pool;
@ -62,11 +62,12 @@ procedure hello is
capa := S.Get_Capacity(Str); capa := S.Get_Capacity(Str);
first := S.Get_First_Index(Str); first := S.Get_First_Index(Str);
last := S.Get_Last_Index(Str); last := S.Get_Last_Index(Str);
Ada.Text_IO.Put (Name & " len:" & len'Img & " capa:" & capa'Img & " first:" & first'img & " last:" & last'img & " => "); Ada.Text_IO.Put (Name & " len:" & len'Img & " capa:" & capa'Img & " first:" & first'Img & " last:" & last'Img & " => ");
Ada.Wide_Text_IO.Put_line (Standard.Wide_String(S.To_Item_Array(Str))); Ada.Wide_Text_IO.Put_line (Standard.Wide_String(S.To_Item_Array(Str)));
if S.Terminator_Length > 0 then if S.Get_Terminator_Length(Str) > 0 then
pragma Assert (S.Get_Item(Str, S.Get_Last_Index(Str) + 1) = S.Terminator_Value); pragma Assert (S.Get_Item(Str, S.Get_Last_Index(Str) + 1) = S.Get_Terminator_Value(Str));
null;
end if; end if;
end print_string_info; end print_string_info;
@ -103,7 +104,7 @@ begin
z: LL_Pointer; z: LL_Pointer;
procedure Dealloc is new Ada.Unchecked_Deallocation(L, LL_Pointer); procedure Dealloc is new Ada.Unchecked_Deallocation(L, LL_Pointer);
begin begin
z := new L'(A => 9900, B => 9800, C => 99.1); z := new L'(A => 9900, B => 9800, C => 99.1);
Ada.Text_IO.Put_Line (Z.A'Img); Ada.Text_IO.Put_Line (Z.A'Img);
Dealloc (z); Dealloc (z);
end; end;
@ -117,14 +118,13 @@ begin
IP.Deallocate (i); IP.Deallocate (i);
TP.Deallocate (x); TP.Deallocate (x);
LP.Deallocate (y); LP.Deallocate (y);
--GNAT.Debug_Pools.Print_Info_Stdout(P2); --GNAT.Debug_Pools.Print_Info_Stdout(P2);
--GNAT.Debug_Pools.Dump_Stdout(P2, 100); --GNAT.Debug_Pools.Dump_Stdout(P2, 100);
declare declare
str: S.Elastic_String; str: S.Elastic_String;
str2: S.Elastic_String; str2: S.Elastic_String;
begin begin
print_string_info (Str, "Str"); print_string_info (Str, "Str");
pragma Assert (S.Get_Length(Str) = 0); pragma Assert (S.Get_Length(Str) = 0);
@ -160,7 +160,7 @@ begin
pragma Assert (S.Get_Length(Str) = 15); pragma Assert (S.Get_Length(Str) = 15);
pragma Assert (S.Get_First_Index(Str) = 1); pragma Assert (S.Get_First_Index(Str) = 1);
pragma Assert (S.Get_Last_Index(Str) = 15); pragma Assert (S.Get_Last_Index(Str) = 15);
S.Append(Str, "donkey"); S.Append(Str, "donkey");
print_string_info (Str, "Str"); print_string_info (Str, "Str");
pragma Assert (S.Get_Length(Str) = 21); pragma Assert (S.Get_Length(Str) = 21);
@ -178,19 +178,19 @@ begin
--arr: constant S.P.Item_Array := S.To_Item_Array(Str); --arr: constant S.P.Item_Array := S.To_Item_Array(Str);
arr: constant S.Rune_Array := S.To_Item_Array(Str); arr: constant S.Rune_Array := S.To_Item_Array(Str);
begin begin
Ada.Wide_Text_IO.Put ("STR[1] => ["); Ada.Wide_Text_IO.Put ("STR[1] => [");
for i in arr'Range loop for i in arr'Range loop
Ada.Wide_Text_IO.Put (arr(i)); Ada.Wide_Text_IO.Put (arr(i));
end loop; end loop;
Ada.Wide_Text_IO.Put_Line ("]"); Ada.Wide_Text_IO.Put_Line ("]");
Ada.Wide_Text_IO.Put ("STR[2] => ["); Ada.Wide_Text_IO.Put ("STR[2] => [");
for i in S.Get_First_Index(Str) .. S.Get_Last_Index(Str) loop for i in S.Get_First_Index(Str) .. S.Get_Last_Index(Str) loop
Ada.Wide_Text_IO.Put (S.Get_Item(Str, i)); Ada.Wide_Text_IO.Put (S.Get_Item(Str, i));
end loop; end loop;
Ada.Wide_Text_IO.Put_Line ("]"); Ada.Wide_Text_IO.Put_Line ("]");
Ada.Wide_Text_IO.Put ("STR[3] => ["); Ada.Wide_Text_IO.Put ("STR[3] => [");
Ada.Wide_Text_IO.Put (Standard.Wide_String(arr)); Ada.Wide_Text_IO.Put (Standard.Wide_String(arr));
Ada.Wide_Text_IO.Put_Line ("]"); Ada.Wide_Text_IO.Put_Line ("]");
end; end;
@ -241,7 +241,7 @@ begin
pragma Assert (S.Get_First_Index(Str) = 1); pragma Assert (S.Get_First_Index(Str) = 1);
pragma Assert (S.Get_Last_Index(Str) = 38); pragma Assert (S.Get_Last_Index(Str) = 38);
pragma Assert (S."="(Str, "Oh! Hello, world! donkey>donkeyXABCDE")); pragma Assert (S."="(Str, "Oh! Hello, world! donkey>donkeyXABCDE"));
S.Replace (Str2, 1, 1, 'Q'); S.Replace (Str2, 1, 1, 'Q');
print_string_info (Str2, "Str2"); print_string_info (Str2, "Str2");
pragma Assert (S.Get_Length(Str2) = 91); pragma Assert (S.Get_Length(Str2) = 91);
@ -319,35 +319,35 @@ begin
pragma Assert (S.Get_Last_Index(Str2) = 92); pragma Assert (S.Get_Last_Index(Str2) = 92);
pragma Assert (S."="(Str2, "AACC Hello, world! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR H3")); pragma Assert (S."="(Str2, "AACC Hello, world! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR H3"));
S.Replace (Str2, 1, 5, ""); S.Replace (Str2, 1, 5, "");
print_string_info (Str2, "Str2"); print_string_info (Str2, "Str2");
pragma Assert (S.Get_Length(Str2) = 87); pragma Assert (S.Get_Length(Str2) = 87);
pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_First_Index(Str2) = 1);
pragma Assert (S.Get_Last_Index(Str2) = 87); pragma Assert (S.Get_Last_Index(Str2) = 87);
pragma Assert (S."="(Str2, "Hello, world! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR H3")); pragma Assert (S."="(Str2, "Hello, world! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR H3"));
S.Replace (Str2, 8, 12, "cougar"); S.Replace (Str2, 8, 12, "cougar");
print_string_info (Str2, "Str2"); print_string_info (Str2, "Str2");
pragma Assert (S.Get_Length(Str2) = 88); pragma Assert (S.Get_Length(Str2) = 88);
pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_First_Index(Str2) = 1);
pragma Assert (S.Get_Last_Index(Str2) = 88); pragma Assert (S.Get_Last_Index(Str2) = 88);
pragma Assert (S."="(Str2, "Hello, cougar! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR H3")); pragma Assert (S."="(Str2, "Hello, cougar! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR H3"));
S.Replace (Str2, S.Get_Last_Index(Str2) - 1, S.Get_Last_Index(Str2) + 100, "HH"); S.Replace (Str2, S.Get_Last_Index(Str2) - 1, S.Get_Last_Index(Str2) + 100, "HH");
print_string_info (Str2, "Str2"); print_string_info (Str2, "Str2");
pragma Assert (S.Get_Length(Str2) = 88); pragma Assert (S.Get_Length(Str2) = 88);
pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_First_Index(Str2) = 1);
pragma Assert (S.Get_Last_Index(Str2) = 88); pragma Assert (S.Get_Last_Index(Str2) = 88);
pragma Assert (S."="(Str2, "Hello, cougar! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR HH")); pragma Assert (S."="(Str2, "Hello, cougar! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR HH"));
S.Replace (Str2, 8, 13, "bee"); S.Replace (Str2, 8, 13, "bee");
print_string_info (Str2, "Str2"); print_string_info (Str2, "Str2");
pragma Assert (S.Get_Length(Str2) = 85); pragma Assert (S.Get_Length(Str2) = 85);
pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_First_Index(Str2) = 1);
pragma Assert (S.Get_Last_Index(Str2) = 85); pragma Assert (S.Get_Last_Index(Str2) = 85);
pragma Assert (S."="(Str2, "Hello, bee! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR HH")); pragma Assert (S."="(Str2, "Hello, bee! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR HH"));
S.Replace (Str2, 8, 10, "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ"); S.Replace (Str2, 8, 10, "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ");
print_string_info (Str2, "Str2"); print_string_info (Str2, "Str2");
pragma Assert (S.Get_Length(Str2) = 160); pragma Assert (S.Get_Length(Str2) = 160);
pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_First_Index(Str2) = 1);
@ -362,20 +362,20 @@ begin
use type H3.System_Word; use type H3.System_Word;
begin begin
print_string_info (Str, "Str"); print_string_info (Str, "Str");
Ada.Wide_Text_IO.Put ("STR(By-Pointer) ["); Ada.Wide_Text_IO.Put ("STR(By-Pointer) [");
for i in S.Get_First_Index(Str) .. S.Get_Last_Index(Str) + S.Terminator_Length loop -- this must loop to the terminating null. for i in S.Get_First_Index(Str) .. S.Get_Last_Index(Str) + S.Get_Terminator_Length(Str) loop -- this must loop to the terminating null.
Ada.Wide_Text_IO.Put (arr.all(i)); Ada.Wide_Text_IO.Put (arr.all(i));
end loop; end loop;
Ada.Wide_Text_IO.Put_Line ("]"); Ada.Wide_Text_IO.Put_Line ("]");
print_string_info (Str2, "Str2"); print_string_info (Str2, "Str2");
Ada.Wide_Text_IO.Put ("Str2(By-Pointer) ["); -- this must loop to the terminating null. Ada.Wide_Text_IO.Put ("Str2(By-Pointer) ["); -- this must loop to the terminating null.
for i in S.Get_First_Index(Str2) .. S.Get_Last_Index(Str2) + S.Terminator_Length loop for i in S.Get_First_Index(Str2) .. S.Get_Last_Index(Str2) + S.Get_Terminator_Length(Str) loop
Ada.Wide_Text_IO.Put (arr2.all(i)); Ada.Wide_Text_IO.Put (arr2.all(i));
end loop; end loop;
Ada.Wide_Text_IO.Put_Line ("]"); Ada.Wide_Text_IO.Put_Line ("]");
end; end;
S.Clear (Str2); S.Clear (Str2);
@ -384,7 +384,7 @@ begin
--declare --declare
-- arr: constant Standard.Wide_String := S.To_Item_Array(str); -- arr: constant Standard.Wide_String := S.To_Item_Array(str);
--begin --begin
-- Ada.Wide_Text_IO.Put_Line (arr); -- Ada.Wide_Text_IO.Put_Line (arr);
--end; --end;
SS := Str; SS := Str;
@ -406,7 +406,7 @@ begin
declare declare
T3: Q.Ref_Counted; T3: Q.Ref_Counted;
begin begin
Q.Create (T3, (X => 20, Y => 30)); Q.Create (T3, (X => 20, Y => 30));
T := T3; T := T3;
--Q.Create (T); --Q.Create (T);
end; end;
@ -416,14 +416,50 @@ begin
Q.Get_Item_Pointer(T).X := 12345; Q.Get_Item_Pointer(T).X := 12345;
Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T).Y'Img); Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T).Y'Img);
Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T).X'Img); Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T).X'Img);
Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T2).Y'Img); Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T2).Y'Img);
Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T2).X'Img); Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T2).X'Img);
end; end;
declare
type RR is record
X: Standard.Integer := 3;
Y: Standard.Integer := 4;
end record;
package PP is new H3.Arrays(RR, 1, RR'(X=>1, Y=>4), H3.Storage.Global_Pool_Box);
p1: PP.Elastic_Array;
begin
p1.Append (RR'(X=>9, Y=>9));
p1.Append (RR'(X=>10, Y=>8));
p1.Append (RR'(X=>11, Y=>7));
Ada.Text_IO.Put_Line ("-------------------------------");
for i in p1.Get_First_Index .. p1.Get_Last_Index loop
Ada.Text_IO.Put (" " & p1.Get_Item(i).X'Img);
end loop;
Ada.Text_IO.Put_Line ("");
for i in p1.Get_First_Index .. p1.Get_Last_Index loop
Ada.Text_IO.Put (" " & p1.Get_Item(i).Y'Img);
end loop;
Ada.Text_IO.Put_Line ("");
end;
declare declare
package S_I is new H3.Arrays(Integer, 1, 16#FF#); T: S.Elastic_String;
package PP is new H3.Arrays(S.Elastic_String, 0, T, H3.Storage.Global_Pool_Box);
p1: PP.Elastic_Array;
tt: S.Elastic_String;
begin
p1.Append (T);
p1.Append (T);
Ada.Text_IO.Put_Line ("-------------------------------");
for i in p1.Get_First_Index .. p1.Get_Last_Index loop
Ada.Wide_Text_IO.Put (Standard.Wide_String(p1.Get_Item(i).To_Item_Array));
end loop;
Ada.Text_IO.Put_Line ("");
end;
declare
package S_I is new H3.Arrays(Integer, 1, 16#FF#, H3.Storage.Global_Pool_Box);
t1: S_I.Elastic_Array; t1: S_I.Elastic_Array;
begin begin
S_I.Append (t1, 20, 5); S_I.Append (t1, 20, 5);

7
lib2/hello2.adb
View File

@ -1,6 +1,7 @@
with H3.Arrays; with H3.Arrays;
with H3.Strings; with H3.Strings;
with H3.Runes; with H3.Runes;
with H3.Storage;
with Ada.Text_IO; with Ada.Text_IO;
with Ada.Wide_Text_IO; with Ada.Wide_Text_IO;
with Ada.Assertions; with Ada.Assertions;
@ -8,11 +9,11 @@ with Interfaces.C;
--with Interfaces.C.Strings; --with Interfaces.C.Strings;
with System; 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'First); package A is new H3.Arrays(Standard.Wide_Character, 1, Wide_Character'First, H3.Storage.Global_Pool_Box);
package S is new H3.Strings(Standard.Wide_Character); package S is new H3.Strings(Standard.Wide_Character, H3.Storage.Global_Pool_Box);
package R is new H3.Runes(Standard.Wide_Character); package R is new H3.Runes(Standard.Wide_Character);
package C renames Interfaces.C; package C renames Interfaces.C;

7
lib2/hello3.adb
View File

@ -1,10 +1,9 @@
with H3.Compilers; with H3.Compilers;
with ada.text_io; with H3.Storage;
procedure hello3 is procedure hello3 is
package C is new H3.Compilers(Standard.Wide_Character); package H3C is new H3.Compilers(Standard.Wide_Character, H3.Storage.Global_Pool_Box);
Compiler: H3C.Compiler;
Compiler: C.Compiler;
begin begin
Compiler.Feed ("#include ""abc.txt""; donkey"); Compiler.Feed ("#include ""abc.txt""; donkey");
Compiler.End_Feed; Compiler.End_Feed;