some ada experiments...

lib2/Makefile

@@ -1,4 +1,4 @@
-OPTS := -gnata -gnatW8 -gnatwa -gnatya -gnatyb -gnatyk -gnatyn -gnatyp ##-gnatyt
+OPTS := -gnata -gnatW8 -gnatwa -gnatya -gnatyb -gnatyk -gnatyn -gnatyp -gnat2005 ##-gnatyt
 all: hello hello2 hello3
 
 hello: hello.adb
@@ -11,4 +11,7 @@ hello3: hello3.adb
 	gnat make $(OPTS) hello3
 
 clean:
-	rm -rf *.o *.ali hello hello2 hello3
+	gnat clean hello
+	gnat clean hello2
+	gnat clean hello3
+

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;

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

lib2/h3-compilers.adb

@@ -5,8 +5,20 @@ package body H3.Compilers is
 	package Utf8 is new H3.Utf8(Standard.Character, S.Rune, Char_Array, S.Rune_Array);
 
 	LB_EOF: constant S.Rune_Array := (R.V.Left_Arrow,R.V.UC_E,R.V.UC_O,R.V.UC_F,R.V.Right_Arrow); -- <EOF>
+	LB_EOL: constant S.Rune_Array := (R.V.Left_Arrow,R.V.UC_E,R.V.UC_O,R.V.UC_L,R.V.Right_Arrow); -- <EOL>
 	LB_XINCLUDE: constant S.Rune_Array := (R.V.Number_Sign,R.V.LC_I,R.V.LC_N,R.V.LC_C,R.V.LC_L,R.V.LC_U,R.V.LC_D,R.V.LC_E); -- #include
-
+	LB_CLASS: constant S.Rune_Array := (R.V.LC_C,R.V.LC_L,R.V.LC_A,R.V.LC_S,R.V.LC_S); -- class
+	LB_FUN: constant S.Rune_Array := (R.V.LC_F,R.V.LC_U,R.V.LC_N); -- fun
+	LB_END: constant S.Rune_Array := (R.V.LC_E,R.V.LC_N,R.V.LC_D); -- end
+	LB_IF: constant S.Rune_Array := (R.V.LC_I,R.V.LC_F); -- if
+	LB_ELIF: constant S.Rune_Array := (R.V.LC_E,R.V.LC_L,R.V.LC_I,R.V.LC_F); -- elif
+	LB_ELSE: constant S.Rune_Array := (R.V.LC_E,R.V.LC_L,R.V.LC_S,R.V.LC_E); -- else
+	LB_WHILE: constant S.Rune_Array := (R.V.LC_W,R.V.LC_H,R.V.LC_I,R.V.LC_L,R.V.LC_E); -- while
+	LB_BREAK: constant S.Rune_Array := (R.V.LC_B,R.V.LC_R,R.V.LC_E,R.V.LC_A,R.V.LC_K); -- break
+	LB_CONTINUE: constant S.Rune_Array := (R.V.LC_C,R.V.LC_O,R.V.LC_N,R.V.LC_T,R.V.LC_I,R.V.LC_N,R.V.LC_U,R.V.LC_E); -- continue
+	LB_TRY: constant S.Rune_Array := (R.V.LC_T,R.V.LC_R,R.V.LC_Y); -- try
+	LB_CATCH: constant S.Rune_Array := (R.V.LC_C,R.V.LC_A,R.V.LC_T,R.V.LC_T,R.V.LC_H); -- catch
+	LB_RAISE: constant S.Rune_Array := (R.V.LC_R,R.V.LC_A,R.V.LC_I,R.V.LC_S,R.V.LC_E); -- raise
 
 	procedure Dump_Token (Tk: in Token) is
 	begin
@@ -24,432 +36,156 @@ 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;
+		return R.Is_Rune(Code, R.V.LF); -- TODO: consider different line end convention
+	end Is_Line_Break;
 
-	procedure Start_Token (C: in out Compiler; Ch: in R.Rune) is
+	function Is_Ident_Starter(Code: in R.Code) return Boolean is
 	begin
-		Start_Token (C);
-		S.Append (C.Tk.Buf, Ch);
-	end Start_Token;
+		return R.Is_Alnum(Code) or else
+		       R.Is_Rune(Code, R.V.Underline) or else
+		       R.Is_Rune(Code, R.V.Minus_Sign);
+	end Is_Ident_Starter;
 
-	procedure Start_Token (C: in out Compiler; Code: in R.Code) is
+	function Is_Ident_Char(Code: in R.Code) return Boolean 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;
+		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 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);
+	package body Feeder is
+		procedure Switch_To_Start (C: in out Compiler) is
 		begin
-			S.Current := Code;
-		end;
-		C.Prs.Top := Top;
-	end Push_Parse_State;
+			C.F.Lx.Data := Lex_Data'(State => LX_START);
+		end Switch_To_Start;
 
-	procedure Pop_Parse_State (C: in out Compiler) is
-	begin
-		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);
+		procedure Start (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) is
 		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;
+			null;
+		end Start;
 
-		-- 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: 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
-				raise Syntax_Error with "unblanced inclusion content";
+		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 if;
-		C.Inc.Top := C.Inc.Top - 1;
-		Pop_Parse_State (C);
-	end Pop_Inclusion;
+		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 Parse_Start (C: in out Compiler) is
+	procedure Feed_Char_Code (C: in out Compiler; Code: in R.Code; Consumed: out Boolean) 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 =>
-				null;
-
-			--when TK_NUMBER =>
-			--	null;
-
-			--when TK_CLASS =>
-			--when TK_FUNC =>
-
-			-- plus or minus signed may be allowed here too.
-			-- plusplus or miniusminus may be allowed here too.
-
-			when TK_SEMICOLON =>
-				null;
-
-			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 others =>
-				raise Syntax_Error with "unknown parser state"; -- TODO: change this...
+		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;
 
-	end Got_Token;
-
-	procedure Feed_Char_Code (C: in out Compiler; Code: in R.Code) is
-	begin
-	<<Start_Over>>
-		--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_Space(Code) then
-					-- ignore. carry on
-					null;
-				elsif R.Is_Alpha(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);
-				elsif R.Is_Rune(Code, R.V.Number_Sign) then -- #
-					Set_Lexer_State (C, LX_DIRECTIVE, Code);
-				elsif R.Is_Rune(Code, R.V.Quotation) then -- "
-					Set_Lexer_State (C, LX_CSTR);
-				elsif R.Is_Rune(Code, R.V.Semicolon) then
-					Start_Token (C, Code);
-					End_Token (C, TK_SEMICOLON);
-				else
-					raise Syntax_Error;
-				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_COMMENT =>
-				null;
-
-			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_IDENT =>
-				if R.Is_Alnum(Code) or else R.Is_Rune(Code, R.V.Underline) 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;
+		--raise Internal_Error with "internal error - unknown flx state";
 	end Feed_Char_Code;
 
-	procedure Feed_Inc (C: in out Compiler) is
-		Entry_Top: constant System_Index := C.Inc.Top;
-	begin
-		loop
-			while not Ada.Text_IO.End_Of_File(C.Inc.Streams(C.Inc.Top).Handle) loop
-				declare
-					Ch: Standard.Character;
-				begin
-					Ada.Text_IO.Get (C.Inc.Streams(C.Inc.Top).Handle, Ch);
-					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;
+		begin
+			H3.Trees.New_Node (X);
+		end;
 	end Initialize;
 
 	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;

lib2/h3-compilers.ads

@@ -1,15 +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;
@@ -21,39 +25,31 @@ package H3.Compilers is
 	overriding procedure Finalize (C: in out Compiler);
 
 private
-	type Lexer_State is (
-		LX_START,
-
-		LX_COMMENT,
-		LX_CSTR,
-		LX_DIRECTIVE,
-		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,
 		TK_BYTE,
 		TK_CHAR,
+		TK_COLON,
 		TK_CSTR,
 		TK_DIRECTIVE,
 		TK_DIV,
 		TK_DIVDIV,
+		TK_DOLLARED_LBRACE,
+		TK_DOLLARED_LBRACK,
+		TK_DOLLARED_LPAREN,
 		TK_EOF,
 		TK_EOL,
+		TK_HASHED_LBRACE,
+		TK_HASHED_LBRACK,
+		TK_HASHED_LPAREN,
 		TK_IDENT,
 		TK_GE,
 		TK_GT,
+		TK_LBRACE,
+		TK_LBRACK,
 		TK_LE,
+		TK_LPAREN,
 		TK_LT,
 		TK_MINUS,
 		TK_MINUSMINUS,
@@ -61,6 +57,9 @@ private
 		TK_MULMUL,
 		TK_PLUS,
 		TK_PLUSPLUS,
+		TK_RBRACE,
+		TK_RBRACK,
+		TK_RPAREN,
 		TK_SEMICOLON
 	);
 	type Token is record
@@ -68,16 +67,104 @@ 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 (
 		PS_START,
+
 		PS_INCLUDE_TARGET,
-		PS_INCLUDE_TERMINATOR
+		PS_INCLUDE_TERMINATOR,
+
+		PS_CLASS_1,
+		PS_CLASS_2,
+
+		PS_FUN_1,
+		PS_FUN_2,
+
+		PS_PLAIN_STATEMENT_START
 	);
 
+	type Parse_Data_Code is (
+		PD_VOID,
+		PD_STATEMENT,
+		PD_ASSIGNMENT
+	);
+
+	type Parse_Data(Code: Parse_Data_Code := PD_VOID) is record
+		case Code is
+			when PD_VOID =>
+				null;
+			when PD_STATEMENT =>
+				Stmt_Starter: S.Elastic_String;
+			when PD_ASSIGNMENT =>
+				Assign_Starter: S.Elastic_String;
+		end case;
+	end record;
+
 	type Parse_State is record
 		Current: Parse_State_Code := PS_START;
+		Data: Parse_Data;
 	end record;
 
 	type Parse_State_Array is array(System_Index range<>) of Parse_State;
@@ -104,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;

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;

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;

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;

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;

lib2/h3-runes.adb

@@ -1,9 +1,11 @@
-with System.UTF_32; -- TOOD: remove dependency on this package. create a seperate unicode package.
+--with System.UTF_32; -- TOOD: remove dependency on this package. create a seperate unicode package.
+with H3.UTF_32;
 
 package body H3.Runes is
 
-	package UC renames System.UTF_32;
-	use type System.UTF_32.Category;
+	--package UC renames System.UTF_32;
+	package UC renames H3.UTF_32;
+	use type UC.Category;
 
 	function Is_Alpha (V: in Rune) return Boolean is
 	begin

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

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;
 

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;
 

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

lib2/h3-trees.adb

@@ -0,0 +1,39 @@
+with Ada.Unchecked_Deallocation;
+
+with ada.text_io;
+
+package body H3.Trees is
+
+	procedure New_Node (Tr: in out Tree) is
+		N: Node_Pointer;
+	begin
+		--N := new Node'(Code => NODE_VOID, Next => null );
+		N := new Node;
+
+		N.all := (Code => NODE_VOID, Next => Null);
+		N.Next := Tr.Top;
+		Tr.Top := N;
+
+		ada.text_io.put_line ("new node...");
+	end New_Node;
+
+	procedure Free_Node (Tr: in out Tree; N: in out Node) is
+	begin
+		--case N.Code is
+		--	when NODE_...
+		--end case;
+		null;
+	end Free_Node;
+
+	-- ------------------------------------------------------------------
+
+	overriding procedure Initialize (Tr: in out Tree) is
+	begin
+		null;
+	end Initialize;
+
+	overriding procedure Finalize (Tr: in out Tree) is
+	begin
+		null;
+	end Finalize;
+end H3.Trees;

lib2/h3-trees.ads

@@ -0,0 +1,54 @@
+with Ada.Finalization;
+
+package H3.Trees is
+
+	--package A is new H3.Arrays(XXXX, 0);
+
+	type Node_Code is (
+		NODE_ASSIGN,
+		NODE_CALL,
+		NODE_CLASS,
+		NODE_IF,
+		NODE_FUN,
+		NODE_VOID,
+		NODE_WHILE
+	);
+
+	type Node;
+	type Node_Pointer is access Node;
+
+	type Node(Code: Node_Code := NODE_VOID) is record
+		-- Loc: location.
+		Next: Node_Pointer;
+		case Code is
+			when NODE_ASSIGN =>
+				null;
+			when NODE_CALL =>
+				null;
+			when NODE_CLASS =>
+				null;
+			when NODE_IF =>
+				null;
+			when NODE_FUN =>
+				null;
+			when NODE_VOID =>
+				null;
+			when NODE_WHILE =>
+				null;
+		end case;
+	end record;
+
+	-- parse tree
+	type Tree is new Ada.Finalization.Limited_Controlled with record
+		--Next_Node: System_Index := System_Index'First;
+		--Toplevel_Node := Node;
+		Top: Node_Pointer := null;
+	end record;
+
+	-- ------------------------------------------------------------------
+	procedure New_Node (Tr: in out Tree);
+
+
+	overriding procedure Initialize (Tr: in out Tree);
+	overriding procedure Finalize (Tr: in out Tree);
+end H3.Trees;

lib2/h3-utf_32.ads

@@ -0,0 +1,212 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                        S Y S T E M . U T F _ 3 2                         --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--          Copyright (C) 2005-2018, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package is an internal package that provides basic character
+--  classification capabilities needed by the compiler for handling full
+--  32-bit wide wide characters. We avoid the use of the actual type
+--  Wide_Wide_Character, since we want to use these routines in the compiler
+--  itself, and we want to be able to compile the compiler with old versions
+--  of GNAT that did not implement Wide_Wide_Character.
+
+--  System.UTF_32 should not be directly used from an application program, but
+--  an equivalent package GNAT.UTF_32 can be used directly and provides exactly
+--  the same services. The reason this package is in System is so that it can
+--  with'ed by other packages in the Ada and System hierarchies.
+
+pragma Compiler_Unit_Warning;
+
+package H3.UTF_32 is
+   --pragma Pure;
+
+   type UTF_32 is range 0 .. 16#7FFF_FFFF#;
+   --  So far, the only defined character codes are in 0 .. 16#01_FFFF#
+
+   --  The following type defines the categories from the unicode definitions.
+   --  The one addition we make is Fe, which represents the characters FFFE
+   --  and FFFF in any of the planes.
+
+   type Category is (
+     Cc,   --  Other, Control
+     Cf,   --  Other, Format
+     Cn,   --  Other, Not Assigned
+     Co,   --  Other, Private Use
+     Cs,   --  Other, Surrogate
+     Ll,   --  Letter, Lowercase
+     Lm,   --  Letter, Modifier
+     Lo,   --  Letter, Other
+     Lt,   --  Letter, Titlecase
+     Lu,   --  Letter, Uppercase
+     Mc,   --  Mark, Spacing Combining
+     Me,   --  Mark, Enclosing
+     Mn,   --  Mark, Nonspacing
+     Nd,   --  Number, Decimal Digit
+     Nl,   --  Number, Letter
+     No,   --  Number, Other
+     Pc,   --  Punctuation, Connector
+     Pd,   --  Punctuation, Dash
+     Pe,   --  Punctuation, Close
+     Pf,   --  Punctuation, Final quote
+     Pi,   --  Punctuation, Initial quote
+     Po,   --  Punctuation, Other
+     Ps,   --  Punctuation, Open
+     Sc,   --  Symbol, Currency
+     Sk,   --  Symbol, Modifier
+     Sm,   --  Symbol, Math
+     So,   --  Symbol, Other
+     Zl,   --  Separator, Line
+     Zp,   --  Separator, Paragraph
+     Zs,   --  Separator, Space
+     Fe);  --  relative position FFFE/FFFF in any plane
+
+   function Get_Category (U : UTF_32) return Category;
+   --  Given a UTF32 code, returns corresponding Category, or Cn if
+   --  the code does not have an assigned unicode category.
+
+   --  The following functions perform category tests corresponding to lexical
+   --  classes defined in the Ada standard. There are two interfaces for each
+   --  function. The second takes a Category (e.g. returned by Get_Category).
+   --  The first takes a UTF_32 code. The form taking the UTF_32 code is
+   --  typically more efficient than calling Get_Category, but if several
+   --  different tests are to be performed on the same code, it is more
+   --  efficient to use Get_Category to get the category, then test the
+   --  resulting category.
+
+   function Is_UTF_32_Letter (U : UTF_32)   return Boolean;
+   function Is_UTF_32_Letter (C : Category) return Boolean;
+   pragma Inline (Is_UTF_32_Letter);
+   --  Returns true iff U is a letter that can be used to start an identifier,
+   --  or if C is one of the corresponding categories, which are the following:
+   --    Letter, Uppercase (Lu)
+   --    Letter, Lowercase (Ll)
+   --    Letter, Titlecase (Lt)
+   --    Letter, Modifier  (Lm)
+   --    Letter, Other     (Lo)
+   --    Number, Letter    (Nl)
+
+   function Is_UTF_32_Digit (U : UTF_32)   return Boolean;
+   function Is_UTF_32_Digit (C : Category) return Boolean;
+   pragma Inline (Is_UTF_32_Digit);
+   --  Returns true iff U is a digit that can be used to extend an identifier,
+   --  or if C is one of the corresponding categories, which are the following:
+   --    Number, Decimal_Digit (Nd)
+
+   function Is_UTF_32_Line_Terminator (U : UTF_32) return Boolean;
+   pragma Inline (Is_UTF_32_Line_Terminator);
+   --  Returns true iff U is an allowed line terminator for source programs,
+   --  if U is in the category Zp (Separator, Paragraph), or Zl (Separator,
+   --  Line), or if U is a conventional line terminator (CR, LF, VT, FF).
+   --  There is no category version for this function, since the set of
+   --  characters does not correspond to a set of Unicode categories.
+
+   function Is_UTF_32_Mark (U : UTF_32)   return Boolean;
+   function Is_UTF_32_Mark (C : Category) return Boolean;
+   pragma Inline (Is_UTF_32_Mark);
+   --  Returns true iff U is a mark character which can be used to extend an
+   --  identifier, or if C is one of the corresponding categories, which are
+   --  the following:
+   --    Mark, Non-Spacing (Mn)
+   --    Mark, Spacing Combining (Mc)
+
+   function Is_UTF_32_Other (U : UTF_32)   return Boolean;
+   function Is_UTF_32_Other (C : Category) return Boolean;
+   pragma Inline (Is_UTF_32_Other);
+   --  Returns true iff U is an other format character, which means that it
+   --  can be used to extend an identifier, but is ignored for the purposes of
+   --  matching of identifiers, or if C is one of the corresponding categories,
+   --  which are the following:
+   --    Other, Format (Cf)
+
+   function Is_UTF_32_Punctuation (U : UTF_32)   return Boolean;
+   function Is_UTF_32_Punctuation (C : Category) return Boolean;
+   pragma Inline (Is_UTF_32_Punctuation);
+   --  Returns true iff U is a punctuation character that can be used to
+   --  separate pieces of an identifier, or if C is one of the corresponding
+   --  categories, which are the following:
+   --    Punctuation, Connector (Pc)
+
+   function Is_UTF_32_Space (U : UTF_32)   return Boolean;
+   function Is_UTF_32_Space (C : Category) return Boolean;
+   pragma Inline (Is_UTF_32_Space);
+   --  Returns true iff U is considered a space to be ignored, or if C is one
+   --  of the corresponding categories, which are the following:
+   --    Separator, Space (Zs)
+
+   function Is_UTF_32_Non_Graphic (U : UTF_32)   return Boolean;
+   function Is_UTF_32_Non_Graphic (C : Category) return Boolean;
+   pragma Inline (Is_UTF_32_Non_Graphic);
+   --  Returns true iff U is considered to be a non-graphic character, or if C
+   --  is one of the corresponding categories, which are the following:
+   --    Other, Control (Cc)
+   --    Other, Private Use (Co)
+   --    Other, Surrogate (Cs)
+   --    Separator, Line (Zl)
+   --    Separator, Paragraph (Zp)
+   --    FFFE or FFFF positions in any plane (Fe)
+   --
+   --  Note that the Ada category format effector is subsumed by the above
+   --  list of Unicode categories.
+   --
+   --  Note that Other, Unassigned (Cn) is quite deliberately not included
+   --  in the list of categories above. This means that should any of these
+   --  code positions be defined in future with graphic characters they will
+   --  be allowed without a need to change implementations or the standard.
+   --
+   --  Note that Other, Format (Cf) is also quite deliberately not included
+   --  in the list of categories above. This means that these characters can
+   --  be included in character and string literals.
+
+   --  The following function is used to fold to upper case, as required by
+   --  the Ada 2005 standard rules for identifier case folding. Two
+   --  identifiers are equivalent if they are identical after folding all
+   --  letters to upper case using this routine. A corresponding routine to
+   --  fold to lower case is also provided.
+
+   function UTF_32_To_Lower_Case (U : UTF_32) return UTF_32;
+   pragma Inline (UTF_32_To_Lower_Case);
+   --  If U represents an upper case letter, returns the corresponding lower
+   --  case letter, otherwise U is returned unchanged. The folding rule is
+   --  simply that if the code corresponds to a 10646 entry whose name contains
+   --  the string CAPITAL LETTER, and there is a corresponding entry whose name
+   --  is the same but with CAPITAL LETTER replaced by SMALL LETTER, then the
+   --  code is folded to this SMALL LETTER code. Otherwise the input code is
+   --  returned unchanged.
+
+   function UTF_32_To_Upper_Case (U : UTF_32) return UTF_32;
+   pragma Inline (UTF_32_To_Upper_Case);
+   --  If U represents a lower case letter, returns the corresponding lower
+   --  case letter, otherwise U is returned unchanged. The folding rule is
+   --  simply that if the code corresponds to a 10646 entry whose name contains
+   --  the string SMALL LETTER, and there is a corresponding entry whose name
+   --  is the same but with SMALL LETTER replaced by CAPITAL LETTER, then the
+   --  code is folded to this CAPITAL LETTER code. Otherwise the input code is
+   --  returned unchanged.
+
+end H3.UTF_32;

lib2/h3.ads

@@ -2,7 +2,9 @@ with System;
 with System.Storage_Pools;
 
 package H3 is
-	--pragma Preelaborate (H3);
+	--pragma Pure; -- can be pure if not for System.Storage_Pools;
+	--pragma Preelabotrate;
+	--pragma Preelaborate(H3);
 
 	subtype Boolean is Standard.Boolean;
 	True: constant Boolean := (1 = 1);
@@ -27,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;
 

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

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;
 

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;

lib2/sample-lang.txt

@@ -0,0 +1,115 @@
+ls -laF
+
+print @get-jobs
+print $(get-jobs)
+
+(defun a (a b c)
+	ddddd		
+)
+
+
+
+fun a (a b c) => e f
+	e = 20
+	f = 30		
+end
+
+
+class t
+	fun a(a b c) => e f
+		while a < b
+			if a < b
+			else
+			end
+		end
+
+		for i = 1 to 20
+		end
+	end
+end
+
+
+#####################################################
+
+$() <--- process execution expansion
+{...} <--- range?
+[ 1 2 3 ] <--- array
+
+#() <-- array???
+#[] <-- hash table??
+#{} <-- ???
+#<> <--?
+
+$() <---
+$[] <---
+${} <---
+$<> <---
+
+
+if cmd
+	
+end
+
+while cmd
+end
+
+fun fib a
+	let a = 20 <-- use it as if it's an declaration + init??
+	"let" a = 20 <--- call the command let
+	@a = 20 <-- lvalue
+	$a      <-- rvalue
+	return $a
+end
+
+"fun" fib a  <--- call the command 'fun', fun it not special??
+
+function name as lvalue? function name as rvalue??
+	fib 10 <--- call the function. 
+	let x = fib <--- what is this syntax? assigning the function fib to x? it's not call?
+	let x = $[fib]
+	let x = $[fib < /dev/null >/dev/null]
+
+$(fib a) <-- capture 
+
+@a = $[fib 20]   <-- capture return value
+@a = $(fib 20)  <-- capture stdout??
+
+@a = $[fib $[ls -laF]]  
+@a = $[fib $(ls -laF)]
+
+
+complex expression inside $[] and $()??
+$(
+	printf "abc"; 
+	if ...
+		...
+	else
+		...
+	end
+)
+
+
+class X   ### class X Y <--- Y is a parent class?
+	names := #[] <- array?
+	tools := #{} <- hash table?
+
+	fun __construct name
+		names.add name
+		let k := 20
+		k := $(20 + 30)
+		return k
+
+		@names<20> = "jelly"
+		@tools<"donkey"> = names;
+		@tools.donkey = names?
+		@k = $tools.donkey  >>>> "${tools.donkey}"  ${tools.donkey} "${tools}.donkey"
+	end
+
+	fun say_hi msg
+		print msg
+		ls -laF << execute external command  if the global variable PATH is not null
+		        << external command is disabled if PATH is null
+		/bin/ls -alF  << if the command begins with /, it still allows execution if this feature is not disabled
+		return 20
+	end
+end