From 695c55d8a7372e603c4697b8e074049870d98f43 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Tue, 23 Aug 2022 10:13:02 +0000 Subject: [PATCH] some ada experiments... --- lib2/Makefile | 2 +- lib2/h3-arrays.adb | 14 +- lib2/h3-arrays.ads | 26 +- lib2/h3-compilers.adb | 681 ++++++-------------------------------- lib2/h3-compilers.ads | 92 +++-- lib2/h3-cords.ads | 11 + lib2/h3-io.ads | 21 ++ lib2/h3-limited_pool.adb | 1 - lib2/h3-pool.adb | 2 +- lib2/h3-storage.ads | 47 +++ lib2/h3-storage_pools.adb | 17 +- lib2/h3-storage_pools.ads | 2 + lib2/h3-strings.ads | 17 +- lib2/h3.ads | 12 +- lib2/hello.adb | 100 ++++-- lib2/hello2.adb | 7 +- lib2/hello3.adb | 7 +- 17 files changed, 398 insertions(+), 661 deletions(-) create mode 100644 lib2/h3-cords.ads create mode 100644 lib2/h3-io.ads create mode 100644 lib2/h3-storage.ads diff --git a/lib2/Makefile b/lib2/Makefile index 0a5e92b..7c1b838 100644 --- a/lib2/Makefile +++ b/lib2/Makefile @@ -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 hello: hello.adb diff --git a/lib2/h3-arrays.adb b/lib2/h3-arrays.adb index 212ce41..64047d5 100644 --- a/lib2/h3-arrays.adb +++ b/lib2/h3-arrays.adb @@ -3,6 +3,18 @@ with Ada.Unchecked_Deallocation; package body H3.Arrays is 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 begin 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 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. null; end Initialize; diff --git a/lib2/h3-arrays.ads b/lib2/h3-arrays.ads index ec77ab1..165feb4 100644 --- a/lib2/h3-arrays.ads +++ b/lib2/h3-arrays.ads @@ -1,18 +1,20 @@ with Ada.Finalization; +with H3.Storage; generic - --type Item_Type is private; - type Item_Type is (<>); - G_Terminator_Length: System_Zero_Or_One; - G_Terminator_Value: Item_Type; + type Item_Type is private; -- any limited definite type + --type Item_Type is (<>); -- any discrete 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 --pragma Preelaborate (Arrays); 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 Elastic_Array is tagged private; @@ -23,6 +25,12 @@ package H3.Arrays is subtype Thin_Item_Array is Item_Array(System_Index'Range); 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 Get_Capacity (Obj: in Elastic_Array) return System_Size; @@ -83,10 +91,10 @@ private end record; type Buffer_Pointer is access all Buffer_Record; - --for Buffer_Pointer'Storage_Pool use <> H3'Storage_Pool; + for Buffer_Pointer'Storage_Pool use Storage_Pool_Box.Storage_Pool; --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); type Elastic_Array is new Ada.Finalization.Controlled with record diff --git a/lib2/h3-compilers.adb b/lib2/h3-compilers.adb index cfe1e8d..4bbe858 100644 --- a/lib2/h3-compilers.adb +++ b/lib2/h3-compilers.adb @@ -36,326 +36,10 @@ package body H3.Compilers is end if; end Dump_Rune; - -- ------------------------------------------------------------------- - - procedure Start_Token (C: in out Compiler) is + function Is_Line_Break(Code: in R.Code) return Boolean is begin - C.Tk.Id := TK_EOF; -- indicate the token id is not set yet - -- TODO: store token location. - 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; + return R.Is_Rune(Code, R.V.LF); -- TODO: consider different line end convention + end Is_Line_Break; function Is_Ident_Starter(Code: in R.Code) return Boolean is 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, ...); 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 - <> - --Dump_Rune (Code); - - case C.Lx.State is - when LX_START => - if R.Is_Eof(Code) then - Start_Token (C, LB_EOF); - End_Token (C, TK_EOF); - -- this procedure doesn't prevent you from feeding more runes - -- 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; - + case C.F.Lx.Data.State is + when Feeder.LX_START => + Feeder.Start(C, Code, Consumed); + when Feeder.LX_COMMENT => + Feeder.Comment(C, Code, Consumed); + when Feeder.LX_DT => + Feeder.Delim_Token(C, Code, Consumed); + when Feeder.LX_HC => + Feeder.Hmarked_Token(C, Code, Consumed); end case; + + --raise Internal_Error with "internal error - unknown flx state"; 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 + Consumed: Boolean; + CC: R.Code; + I: System_Index := Data'First; begin - for i in Data'Range loop - Feed_Char_Code (C, R.To_Code(Data(i))); - if C.Inc.Top > 0 then - Feed_Inc (C); + while I <= Data'Last loop + CC := R.To_Code(Data(I)); + Feed_Char_Code (C, CC, consumed); + if Consumed then + Feeder.Update_Location (C, CC); + I := I + 1; 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 Feed; procedure End_Feed (C: in out Compiler) is + Consumed: Boolean; 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; - -- ------------------------------------------------------------------- procedure Initialize (C: in out Compiler) is begin - Push_Parse_State (C, PS_START); + --Push_Parse_State (C, PS_START); declare 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 begin - while C.Inc.Top > 0 loop - Pop_Inclusion (C, False); - end loop; - while C.Prs.Top > 0 loop - Pop_Parse_State (C); - end loop; + --while C.Inc.Top > 0 loop + -- Pop_Inclusion (C, False); + --end loop; + --while C.Prs.Top > 0 loop + -- Pop_Parse_State (C); + --end loop; + null; end Finalize; + end H3.Compilers; diff --git a/lib2/h3-compilers.ads b/lib2/h3-compilers.ads index d57b3ba..b404fb2 100644 --- a/lib2/h3-compilers.ads +++ b/lib2/h3-compilers.ads @@ -1,16 +1,19 @@ with H3.Runes; with H3.Strings; +with H3.Storage; with H3.Trees; with Ada.Finalization; with Ada.Text_IO; generic type Rune_Type is (<>); + with package Storage_Pool_box is new H3.Storage.Pool_Box(<>); package H3.Compilers is 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; + Internal_Error: exception; --type Compiler is tagged limited 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); 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 ( TK_ASSIGN, TK_BSTR, @@ -86,6 +67,67 @@ private Buf: S.Elastic_String; 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 ( @@ -149,10 +191,12 @@ private --type Compiler is tagged limited record type Compiler is new Ada.Finalization.Limited_Controlled with record - Lx: Lexer; + F: Feeder.Feed; + Tk: Token; 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 + end record; end H3.Compilers; diff --git a/lib2/h3-cords.ads b/lib2/h3-cords.ads new file mode 100644 index 0000000..09ff0ff --- /dev/null +++ b/lib2/h3-cords.ads @@ -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; diff --git a/lib2/h3-io.ads b/lib2/h3-io.ads new file mode 100644 index 0000000..f1d1ec8 --- /dev/null +++ b/lib2/h3-io.ads @@ -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; diff --git a/lib2/h3-limited_pool.adb b/lib2/h3-limited_pool.adb index 23cf7fe..1c39ef0 100644 --- a/lib2/h3-limited_pool.adb +++ b/lib2/h3-limited_pool.adb @@ -5,7 +5,6 @@ package body H3.Limited_Pool is function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type is P: Storage_Pool_Pointer; - begin if Pool = null then P := Storage_Pool; diff --git a/lib2/h3-pool.adb b/lib2/h3-pool.adb index 9f2d220..149f7b3 100644 --- a/lib2/h3-pool.adb +++ b/lib2/h3-pool.adb @@ -87,7 +87,7 @@ package body H3.Pool is Tmp: Pooled_Pointer := To_Pooled_Pointer(Target); begin Dealloc (Tmp); - Target := null; + Target := null; end; end if; end Deallocate; diff --git a/lib2/h3-storage.ads b/lib2/h3-storage.ads new file mode 100644 index 0000000..6736ea1 --- /dev/null +++ b/lib2/h3-storage.ads @@ -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 + -- + -- <> + -- + -- 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; diff --git a/lib2/h3-storage_pools.adb b/lib2/h3-storage_pools.adb index cc77e92..f387b97 100644 --- a/lib2/h3-storage_pools.adb +++ b/lib2/h3-storage_pools.adb @@ -1,7 +1,7 @@ with System; with System.Address_Image; -with Ada.Text_IO; +--with Ada.Text_IO; package body H3.Storage_Pools is @@ -20,10 +20,11 @@ package body H3.Storage_Pools is begin tmp := Sys_Malloc(System_Size(((Size + Alignment - 1) / Alignment) * Alignment)); if System."="(tmp, System.Null_Address) then - raise Storage_Error; + --raise H3.Storage_Error; + raise Standard.Storage_Error; else 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 Allocate; @@ -33,14 +34,14 @@ Ada.Text_IO.Put_Line ("Global_Pool Allocating Size: " & SSE.Storage_Count'Image Alignment: in SSE.Storage_Count) is begin ---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 Address: " & System.Address'Img); +--Ada.Text_IO.Put_Line ("Global_Pool Deallocating " & System.Address_Image(Address)); Sys_Free (Address); end Deallocate; function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count is begin -Ada.Text_IO.Put_Line ("Global_Pool Storage_Size "); +--Ada.Text_IO.Put_Line ("Global_Pool Storage_Size "); return SSE.Storage_Count'Last; end Storage_Size; @@ -59,7 +60,7 @@ Ada.Text_IO.Put_Line ("Global_Pool Storage_Size "); Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count) is 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); 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"); 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 -ada.text_io.put_line ("system__storage_pools__deallocate..."); +--ada.text_io.put_line ("system__storage_pools__deallocate..."); SSP.Deallocate (Pool, Address, Size, Alignment); end Deallocate_315P; diff --git a/lib2/h3-storage_pools.ads b/lib2/h3-storage_pools.ads index dc73306..77be2e9 100644 --- a/lib2/h3-storage_pools.ads +++ b/lib2/h3-storage_pools.ads @@ -20,6 +20,8 @@ package H3.Storage_Pools is function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count; + -- TODO: implement more pools + private type Global_Pool is new SSP.Root_Storage_Pool with null record; diff --git a/lib2/h3-strings.ads b/lib2/h3-strings.ads index db87eae..0ee2247 100644 --- a/lib2/h3-strings.ads +++ b/lib2/h3-strings.ads @@ -1,17 +1,27 @@ with H3.Arrays; +with H3.Storage; + + +with H3.Storage_Pools; generic type Rune_Type is (<>); + with package Storage_Pool_Box is new H3.Storage.Pool_Box(<>); 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_Array is P.Item_Array; subtype Thin_Rune_Array_Pointer is P.Thin_Item_Array_Pointer; - Terminator_Length: System_Zero_Or_One renames P.Terminator_Length; - Terminator_Value: Rune renames P.Terminator_Value; + --Terminator_Length: System_Zero_Or_One renames P.Terminator_Length; + --Terminator_Value: Rune renames P.Terminator_Value; type Elastic_String is new P.Elastic_Array with record --A: standard.integer := 999; @@ -24,3 +34,4 @@ package H3.Strings is overriding procedure Append (Obj: in out Elastic_String; V: in Rune_Array); end H3.Strings; + diff --git a/lib2/h3.ads b/lib2/h3.ads index 6c9eea9..da93b21 100644 --- a/lib2/h3.ads +++ b/lib2/h3.ads @@ -29,15 +29,21 @@ package H3 is +(2 ** (System_Word_Bits - 1)) - 1; for System_Signed_Word'Size use System_Word_Bits; - --type System_Size is new System_Word range 0 .. (2 ** System_Word_Bits) - 1; - subtype System_Size is System_Word range 0 .. (2 ** System_Word_Bits) - 1; + -- Don't include the max value of System_Word in System_Size. + -- 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 (System_Size'First + 1) .. System_Size'Last; 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; diff --git a/lib2/hello.adb b/lib2/hello.adb index 82220fc..259b434 100644 --- a/lib2/hello.adb +++ b/lib2/hello.adb @@ -2,6 +2,7 @@ with H3.Pool; with H3.Limited_Pool; with H3.Arrays; with H3.Strings; +with H3.Storage; with H3.Storage_Pools; with H3.MM; with GNAT.Debug_Pools; @@ -15,8 +16,7 @@ with Ada.Assertions; use type H3.System_Size; 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; P1: aliased System.Pool_Global.Unbounded_No_Reclaim_Pool; @@ -62,11 +62,12 @@ procedure hello is capa := S.Get_Capacity(Str); first := S.Get_First_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))); - if S.Terminator_Length > 0 then - pragma Assert (S.Get_Item(Str, S.Get_Last_Index(Str) + 1) = S.Terminator_Value); + if S.Get_Terminator_Length(Str) > 0 then + pragma Assert (S.Get_Item(Str, S.Get_Last_Index(Str) + 1) = S.Get_Terminator_Value(Str)); + null; end if; end print_string_info; @@ -103,7 +104,7 @@ begin z: LL_Pointer; procedure Dealloc is new Ada.Unchecked_Deallocation(L, LL_Pointer); 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); Dealloc (z); end; @@ -117,14 +118,13 @@ begin IP.Deallocate (i); TP.Deallocate (x); LP.Deallocate (y); - + --GNAT.Debug_Pools.Print_Info_Stdout(P2); --GNAT.Debug_Pools.Dump_Stdout(P2, 100); - + declare str: S.Elastic_String; str2: S.Elastic_String; - begin print_string_info (Str, "Str"); pragma Assert (S.Get_Length(Str) = 0); @@ -160,7 +160,7 @@ begin pragma Assert (S.Get_Length(Str) = 15); pragma Assert (S.Get_First_Index(Str) = 1); pragma Assert (S.Get_Last_Index(Str) = 15); - + S.Append(Str, "donkey"); print_string_info (Str, "Str"); 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.Rune_Array := S.To_Item_Array(Str); begin - Ada.Wide_Text_IO.Put ("STR[1] => ["); + Ada.Wide_Text_IO.Put ("STR[1] => ["); for i in arr'Range loop - Ada.Wide_Text_IO.Put (arr(i)); + Ada.Wide_Text_IO.Put (arr(i)); end loop; 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 - Ada.Wide_Text_IO.Put (S.Get_Item(Str, i)); + Ada.Wide_Text_IO.Put (S.Get_Item(Str, i)); end loop; 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_Line ("]"); end; @@ -241,7 +241,7 @@ begin pragma Assert (S.Get_First_Index(Str) = 1); pragma Assert (S.Get_Last_Index(Str) = 38); pragma Assert (S."="(Str, "Oh! Hello, world! donkey>donkeyXABCDE")); - + S.Replace (Str2, 1, 1, 'Q'); print_string_info (Str2, "Str2"); pragma Assert (S.Get_Length(Str2) = 91); @@ -319,35 +319,35 @@ begin 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")); - S.Replace (Str2, 1, 5, ""); + S.Replace (Str2, 1, 5, ""); print_string_info (Str2, "Str2"); pragma Assert (S.Get_Length(Str2) = 87); pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_Last_Index(Str2) = 87); 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"); pragma Assert (S.Get_Length(Str2) = 88); pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_Last_Index(Str2) = 88); 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"); pragma Assert (S.Get_Length(Str2) = 88); pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_Last_Index(Str2) = 88); 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"); pragma Assert (S.Get_Length(Str2) = 85); pragma Assert (S.Get_First_Index(Str2) = 1); pragma Assert (S.Get_Last_Index(Str2) = 85); 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"); pragma Assert (S.Get_Length(Str2) = 160); pragma Assert (S.Get_First_Index(Str2) = 1); @@ -362,20 +362,20 @@ begin use type H3.System_Word; begin print_string_info (Str, "Str"); - - 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. + + Ada.Wide_Text_IO.Put ("STR(By-Pointer) ["); + 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)); end loop; - Ada.Wide_Text_IO.Put_Line ("]"); + Ada.Wide_Text_IO.Put_Line ("]"); print_string_info (Str2, "Str2"); - + 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)); end loop; - Ada.Wide_Text_IO.Put_Line ("]"); + Ada.Wide_Text_IO.Put_Line ("]"); end; S.Clear (Str2); @@ -384,7 +384,7 @@ begin --declare -- arr: constant Standard.Wide_String := S.To_Item_Array(str); --begin - -- Ada.Wide_Text_IO.Put_Line (arr); + -- Ada.Wide_Text_IO.Put_Line (arr); --end; SS := Str; @@ -406,7 +406,7 @@ begin declare T3: Q.Ref_Counted; begin - Q.Create (T3, (X => 20, Y => 30)); + Q.Create (T3, (X => 20, Y => 30)); T := T3; --Q.Create (T); end; @@ -416,14 +416,50 @@ begin 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).X'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); 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 - 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; begin S_I.Append (t1, 20, 5); diff --git a/lib2/hello2.adb b/lib2/hello2.adb index a5252a1..8f3d003 100644 --- a/lib2/hello2.adb +++ b/lib2/hello2.adb @@ -1,6 +1,7 @@ with H3.Arrays; with H3.Strings; with H3.Runes; +with H3.Storage; with Ada.Text_IO; with Ada.Wide_Text_IO; with Ada.Assertions; @@ -8,11 +9,11 @@ with Interfaces.C; --with Interfaces.C.Strings; with System; -use type H3.System_Size; +--use type H3.System_Size; procedure hello2 is - package A is new H3.Arrays(Standard.Wide_Character, 1, Wide_Character'First); - package S is new H3.Strings(Standard.Wide_Character); + 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, H3.Storage.Global_Pool_Box); package R is new H3.Runes(Standard.Wide_Character); package C renames Interfaces.C; diff --git a/lib2/hello3.adb b/lib2/hello3.adb index 7073fd6..9354d15 100644 --- a/lib2/hello3.adb +++ b/lib2/hello3.adb @@ -1,10 +1,9 @@ with H3.Compilers; -with ada.text_io; +with H3.Storage; procedure hello3 is - package C is new H3.Compilers(Standard.Wide_Character); - - Compiler: C.Compiler; + package H3C is new H3.Compilers(Standard.Wide_Character, H3.Storage.Global_Pool_Box); + Compiler: H3C.Compiler; begin Compiler.Feed ("#include ""abc.txt""; donkey"); Compiler.End_Feed;