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
hello: hello.adb

14
lib2/h3-arrays.adb
View File

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

26
lib2/h3-arrays.ads
View File

@ -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 <<TODO: custom storage pool?>> 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

655
lib2/h3-compilers.adb
View File

@ -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
<<Start_Over>>
--Dump_Rune (Code);
C.F.Lx.Data := Lex_Data'(State => LX_START);
end Switch_To_Start;
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
procedure Start (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
begin
null;
end Start;
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);
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;
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);
procedure Delim_Token (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
begin
null;
end Delim_Token;
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);
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
raise Syntax_Error;
C.F.Lx.Loc.Colm := C.F.Lx.Loc.Colm + 1;
end if;
end Update_Location;
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;
procedure Begin_Include (C: in out Compiler) is
begin
null;
end Begin_Include;
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;
procedure Feed_From_Includee (C: in out Compiler) is
begin
null;
end Feed_From_Includee;
end Feeder;
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;
-- -------------------------------------------------------------------
procedure Feed_Char_Code (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
begin
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;

92
lib2/h3-compilers.ads
View File

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

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
P: Storage_Pool_Pointer;
begin
if Pool = null then
P := Storage_Pool;

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

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;
-- TODO: implement more pools
private
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.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;

12
lib2/h3.ads
View File

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

54
lib2/hello.adb
View File

@ -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;
@ -124,7 +125,6 @@ begin
declare
str: S.Elastic_String;
str2: S.Elastic_String;
begin
print_string_info (Str, "Str");
pragma Assert (S.Get_Length(Str) = 0);
@ -364,7 +364,7 @@ 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.
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 ("]");
@ -372,7 +372,7 @@ begin
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 ("]");
@ -421,9 +421,45 @@ begin
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);

7
lib2/hello2.adb
View File

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

7
lib2/hello3.adb
View File

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