summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/packrat-lexer.adb346
-rw-r--r--src/packrat-lexer.ads129
2 files changed, 320 insertions, 155 deletions
diff --git a/src/packrat-lexer.adb b/src/packrat-lexer.adb
index 7cbd527..77ebf9f 100644
--- a/src/packrat-lexer.adb
+++ b/src/packrat-lexer.adb
@@ -13,32 +13,30 @@ package body Packrat.Lexer is
procedure Initialize
- (This : in out Combinator_Result) is
+ (This : in out Lexer_Context) is
begin
null;
end Initialize;
procedure Adjust
- (This : in out Combinator_Result) is
+ (This : in out Lexer_Context)
+ is
+ New_Array : Element_Array_Access;
begin
- if This.Value /= null then
- declare
- New_Array : Element_Array_Access :=
- new Element_Array (1 .. This.Value.all'Length);
- begin
- New_Array.all := This.Value.all;
- This.Value := New_Array;
- end;
+ if This.Pass_Forward /= null then
+ New_Array := new Element_Array (1 .. This.Pass_Forward.all'Length);
+ New_Array.all := This.Pass_Forward.all;
+ This.Pass_Forward := New_Array;
end if;
end Adjust;
procedure Finalize
- (This : in out Combinator_Result) is
+ (This : in out Lexer_Context) is
begin
- if This.Value /= null then
- Free_Array (This.Value);
+ if This.Pass_Forward /= null then
+ Free_Array (This.Pass_Forward);
end if;
end Finalize;
@@ -46,85 +44,46 @@ package body Packrat.Lexer is
- function "="
- (Left, Right : in Combinator_Result)
- return Boolean
- is
- Left_Valsize, Right_Valsize : Natural;
+ procedure Finalize
+ (This : in out Input_Container) is
begin
- if Left.Value = null then
- Left_Valsize := 0;
- else
- Left_Valsize := Left.Value.all'Length;
+ if This.Dealloc then
+ Free_Array (This.Data);
end if;
- if Right.Value = null then
- Right_Valsize := 0;
- else
- Right_Valsize := Right.Value.all'Length;
- end if;
-
- return Left.Length = Right.Length and
- Left.Status = Right.Status and
- Left_Valsize = Right_Valsize and
- (Left_Valsize = 0 or else Left.Value.all = Right.Value.all);
- end "=";
+ end Finalize;
+ function Pass_Input
+ (Passed, Continuing : in Element_Array_Access)
+ return Input_Container is
+ begin
+ if Passed = null then
+ return This : Input_Container do
+ This.Data := Continuing;
+ This.Dealloc := False;
+ end return;
+ else
+ return This : Input_Container do
+ This.Data := new Element_Array (1 .. Passed'Length + Continuing'Length);
+ This.Data (1 .. Passed'Length) := Passed.all;
+ This.Data (Passed'Length + 1 .. This.Data'Last) := Continuing.all;
+ This.Dealloc := True;
+ end return;
+ end if;
+ end Pass_Input;
- function Create_Result
- (Length : in Natural;
- Status : in Result_Status;
- Value : in Element_Array)
- return Combinator_Result
- is
- This : Combinator_Result;
- begin
- This.Length := Length;
- This.Status := Status;
- This.Value := new Element_Array (1 .. Value'Length);
- This.Value.all := Value;
- return This;
- end Create_Result;
function Join
(Left, Right : in Combinator_Result)
- return Combinator_Result
- is
- Merge : Combinator_Result;
- Left_Valsize, Right_Valsize, Total_Valsize : Natural;
+ return Combinator_Result is
begin
- if Left.Value /= null then
- Left_Valsize := Left.Value.all'Length;
- else
- Left_Valsize := 0;
- end if;
- if Right.Value /= null then
- Right_Valsize := Right.Value.all'Length;
- else
- Right_Valsize := 0;
- end if;
- Total_Valsize := Left_Valsize + Right_Valsize;
-
if Left.Status = Success or Left.Status = Optional_More then
- Merge.Length := Left.Length + Right.Length;
- Merge.Status := Right.Status;
- if Total_Valsize > 0 then
- Merge.Value := new Element_Array (1 .. Total_Valsize);
- if Left.Value /= null then
- Merge.Value.all (1 .. Left_Valsize) := Left.Value.all;
- end if;
- if Right.Value /= null then
- Merge.Value.all (Left_Valsize + 1 .. Total_Valsize) := Right.Value.all;
- end if;
- end if;
- return Merge;
+ return (Integer'Max (Left.Finish, Right.Finish), Right.Status);
elsif Left.Status = Needs_More then
- Merge := Left;
- Merge.Status := Failure;
- return Merge;
+ return (Left.Finish, Failure);
else
return Left;
end if;
@@ -134,33 +93,174 @@ package body Packrat.Lexer is
- procedure Stamp
+ function Stamp
(Input : in Element_Array;
- Context : in out Lexer_Context) is
+ Context : in out Lexer_Context)
+ return Component_Result
+ is
+ Current_Result : Combinator_Result :=
+ Combo (Input, Context.Position);
begin
- null;
+ if Context.Status /= Success or Context.Position > Input'Last or
+ Context.Empty_Labels.Contains (Label)
+ then
+ return Component_Failure;
+ end if;
+
+ if (Current_Result.Status = Needs_More and not Context.Allow_Incomplete) or
+ Current_Result.Status = Failure
+ then
+ Context.Error_Labels.Append (Label);
+ return Component_Failure;
+ end if;
+
+ if (Current_Result.Status = Optional_More and not Context.Allow_Incomplete) or
+ Current_Result.Status = Success
+ then
+ Context.Result_So_Far.Append (Gen_Tokens.Create
+ (Label,
+ Context.Position + Context.Offset,
+ Current_Result.Finish + Context.Offset,
+ Input (Context.Position .. Current_Result.Finish)));
+ if Current_Result.Finish = 0 then
+ Context.Empty_Labels.Insert (Label);
+ else
+ Context.Empty_Labels.Clear;
+ Context.Position := Current_Result.Finish + 1;
+ end if;
+ else
+ Context.Status := Current_Result.Status;
+ Context.Pass_Forward := new Element_Array
+ (1 .. Current_Result.Finish - Context.Position + 1);
+ Context.Pass_Forward.all := Input (Context.Position .. Current_Result.Finish);
+ Context.Empty_Labels.Clear;
+ end if;
+
+ Context.Error_Labels.Clear;
+ return Component_Success;
end Stamp;
- procedure Ignore
+ function Ignore
(Input : in Element_Array;
- Context : in out Lexer_Context) is
+ Context : in out Lexer_Context)
+ return Component_Result
+ is
+ Current_Result : Combinator_Result :=
+ Combo (Input, Context.Position);
begin
- null;
+ if Context.Status /= Success or Context.Position > Input'Last or
+ Context.Empty_Labels.Contains (Label)
+ then
+ return Component_Failure;
+ end if;
+
+ if (Current_Result.Status = Needs_More and not Context.Allow_Incomplete) or
+ Current_Result.Status = Failure
+ then
+ Context.Error_Labels.Append (Label);
+ return Component_Failure;
+ end if;
+
+ if (Current_Result.Status = Optional_More and not Context.Allow_Incomplete) or
+ Current_Result.Status = Success
+ then
+ if Current_Result.Finish = 0 then
+ Context.Empty_Labels.Insert (Label);
+ else
+ Context.Empty_Labels.Clear;
+ Context.Position := Current_Result.Finish + 1;
+ end if;
+ else
+ Context.Status := Current_Result.Status;
+ Context.Pass_Forward := new Element_Array
+ (1 .. Current_Result.Finish - Context.Position + 1);
+ Context.Pass_Forward.all := Input (Context.Position .. Current_Result.Finish);
+ Context.Empty_Labels.Clear;
+ end if;
+
+ Context.Error_Labels.Clear;
+ return Component_Success;
end Ignore;
+ procedure Tidy_Context
+ (Details : in out Lexer_Context;
+ Number_Comp : in Ada.Containers.Count_Type) is
+ begin
+ if Details.Pass_Forward /= null then
+ Free_Array (Details.Pass_Forward);
+ Details.Pass_Forward := null;
+ end if;
+
+ Details.Result_So_Far.Clear;
+ Details.Empty_Labels.Clear;
+ Details.Error_Labels.Clear;
+ Details.Error_Labels.Reserve_Capacity (Number_Comp);
+
+ Details.Offset := Details.Offset + Details.Position - 1;
+ Details.Position := 1;
+ Details.Status := Success;
+ end Tidy_Context;
+
+
+ procedure Raise_Lexer_Error
+ (Label_List : in Label_Vectors.Vector;
+ Position : in Positive)
+ is
+ Error_Info_List : Errors.Error_Info_Array
+ (Label_List.First_Index .. Label_List.Last_Index);
+ begin
+ for I in Integer range Error_Info_List'First .. Error_Info_List'Last loop
+ Error_Info_List (I).Symbol := +Label_Enum'Image (Label_List.Element (I));
+ Error_Info_List (I).Position := Position;
+ end loop;
+ raise Lexer_Error with Errors.Encode_Array (Error_Info_List);
+ end Raise_Lexer_Error;
+
+
+ function Token_Vector_To_Array
+ (Input_Vector : in Token_Vectors.Vector)
+ return Gen_Tokens.Token_Array
+ is
+ Result_Array : Gen_Tokens.Token_Array (1 .. Integer (Input_Vector.Length));
+ begin
+ for I in Integer range 1 .. Integer (Input_Vector.Length) loop
+ Result_Array (I) := Input_Vector.Element (I);
+ end loop;
+ return Result_Array;
+ end Token_Vector_To_Array;
+
+
function Scan
(Input : in Element_Array;
Context : in out Lexer_Context)
return Gen_Tokens.Token_Array
is
- Result : Gen_Tokens.Token_Array (1 .. 0);
+ Real_Input : Input_Container :=
+ Pass_Input (Context.Pass_Forward, Input'Unrestricted_Access);
+ Raise_Error : Boolean;
begin
- return Result;
+ Tidy_Context (Context, Components'Length);
+ Context.Allow_Incomplete := not (Input = Empty_Array);
+
+ while Context.Status = Success and Context.Position <= Real_Input.Data'Length loop
+ Raise_Error := True;
+ for C of Components loop
+ if C (Real_Input.Data.all, Context) = Component_Success then
+ Raise_Error := False;
+ exit;
+ end if;
+ end loop;
+ if Raise_Error then
+ Raise_Lexer_Error (Context.Error_Labels, Context.Position);
+ end if;
+ end loop;
+
+ return Token_Vector_To_Array (Context.Result_So_Far);
end Scan;
@@ -169,14 +269,32 @@ package body Packrat.Lexer is
Context : in out Lexer_Context)
return Gen_Tokens.Token_Array
is
- Result : Gen_Tokens.Token_Array (1 .. 0);
+ Real_Input : Input_Container :=
+ Pass_Input (Context.Pass_Forward, Input'Unrestricted_Access);
+ Raise_Error : Boolean;
begin
- return Result;
+ Tidy_Context (Context, Components'Length);
+ Context.Allow_Incomplete := False;
+
+ while Context.Status = Success and Context.Position <= Real_Input.Data'Length loop
+ Raise_Error := True;
+ for C of Components loop
+ if C (Real_Input.Data.all, Context) = Component_Success then
+ Raise_Error := False;
+ exit;
+ end if;
+ end loop;
+ if Raise_Error then
+ Raise_Lexer_Error (Context.Error_Labels, Context.Position);
+ end if;
+ end loop;
+
+ return Token_Vector_To_Array (Context.Result_So_Far);
end Scan_Only;
function Scan_With
- (Input : in Lexer_With_Input;
+ (Input : in With_Input;
Context : in out Lexer_Context)
return Gen_Tokens.Token_Array
is
@@ -196,7 +314,7 @@ package body Packrat.Lexer is
procedure Scan_Set_With
- (Input : in Lexer_With_Input;
+ (Input : in With_Input;
Context : in out Lexer_Context;
Output : out Gen_Tokens.Token_Array) is
begin
@@ -212,7 +330,7 @@ package body Packrat.Lexer is
Start : in Positive)
return Combinator_Result
is
- Result : Combinator_Result := Create_Result (0, Success, Empty_Array);
+ Result : Combinator_Result := (0, Success);
Position : Positive := Start;
begin
if Start > Input'Last then
@@ -225,7 +343,7 @@ package body Packrat.Lexer is
end if;
Result := Join (Result, C (Input, Position));
exit when Result.Status = Failure;
- Position := Start + Result.Length;
+ Position := Result.Finish + 1;
end loop;
return Result;
end Sequence;
@@ -236,7 +354,7 @@ package body Packrat.Lexer is
Start : in Positive)
return Combinator_Result
is
- Result : Combinator_Result := Create_Result (0, Success, Empty_Array);
+ Result : Combinator_Result := (0, Success);
Position : Positive := Start;
begin
if Start > Input'Last then
@@ -249,7 +367,7 @@ package body Packrat.Lexer is
end if;
Result := Join (Result, Param (Input, Position));
exit when Result.Status = Failure;
- Position := Start + Result.Length;
+ Position := Result.Finish + 1;
end loop;
return Result;
end Count;
@@ -260,7 +378,7 @@ package body Packrat.Lexer is
Start : in Positive)
return Combinator_Result
is
- Result : Combinator_Result := Create_Result (0, Success, Empty_Array);
+ Result : Combinator_Result := (0, Success);
Temp : Combinator_Result;
Position : Positive := Start;
Counter : Natural := 0;
@@ -274,7 +392,7 @@ package body Packrat.Lexer is
exit when Temp.Status = Failure or Temp.Status = Needs_More;
Result := Join (Result, Temp);
Counter := Counter + 1;
- Position := Start + Result.Length;
+ Position := Result.Finish + 1;
end loop;
if Counter < Minimum then
if Position > Input'Last or Temp.Status = Needs_More then
@@ -296,7 +414,7 @@ package body Packrat.Lexer is
Start : in Positive)
return Combinator_Result
is
- Result : Combinator_Result := Create_Result (0, Success, Empty_Array);
+ Result : Combinator_Result := (0, Success);
Temp : Combinator_Result;
Position : Positive := Start;
Counter : Natural := 0;
@@ -310,7 +428,7 @@ package body Packrat.Lexer is
exit when Temp.Status = Failure or Temp.Status = Needs_More or Test (Input (Position));
Result := Join (Result, Temp);
Counter := Counter + 1;
- Position := Start + Result.Length;
+ Position := Result.Finish + 1;
end loop;
if Counter < Minimum then
if Position > Input'Last or Temp.Status = Needs_More then
@@ -342,7 +460,7 @@ package body Packrat.Lexer is
if Start > Input'Last then
return Empty_Fail;
elsif Test (Input (Start)) then
- return Create_Result (1, Success, (1 => Input (Start)));
+ return (Start, Success);
else
return Empty_Fail;
end if;
@@ -357,7 +475,7 @@ package body Packrat.Lexer is
if Start > Input'Last then
return Empty_Fail;
elsif Test (Change (Input (Start))) then
- return Create_Result (1, Success, (1 => Input (Start)));
+ return (Start, Success);
else
return Empty_Fail;
end if;
@@ -372,7 +490,7 @@ package body Packrat.Lexer is
if Start > Input'Last then
return Empty_Fail;
elsif Input (Start) = Item then
- return Create_Result (1, Success, (1 => Item));
+ return (Start, Success);
else
return Empty_Fail;
end if;
@@ -387,7 +505,7 @@ package body Packrat.Lexer is
if Start > Input'Last then
return Empty_Fail;
elsif Change (Input (Start)) = Item then
- return Create_Result (1, Success, (1 => Input (Start)));
+ return (Start, Success);
else
return Empty_Fail;
end if;
@@ -402,7 +520,7 @@ package body Packrat.Lexer is
Current_Offset : Natural := 0;
begin
if Items'Length = 0 then
- return Create_Result (0, Success, Empty_Array);
+ return (0, Success);
end if;
if Input'Last - Start + 1 <= 0 then
@@ -411,13 +529,17 @@ package body Packrat.Lexer is
while Input (Start + Current_Offset) = Items (Items'First + Current_Offset) loop
if Items'First + Current_Offset = Items'Last then
- return Create_Result (Current_Offset + 1, Success, Items);
+ return (Start + Current_Offset, Success);
elsif Start + Current_Offset = Input'Last then
- return Create_Result (Current_Offset + 1, Needs_More, Input (Start .. Input'Last));
+ return (Start + Current_Offset, Needs_More);
end if;
Current_Offset := Current_Offset + 1;
end loop;
- return Create_Result (Current_Offset, Failure, Input (Start .. Start + Current_Offset - 1));
+ if Current_Offset = 0 then
+ return Empty_Fail;
+ else
+ return (Start + Current_Offset - 1, Failure);
+ end if;
end Multimatch;
@@ -429,9 +551,9 @@ package body Packrat.Lexer is
if Start > Input'Last then
return Empty_Fail;
elsif Start + Number - 1 > Input'Last then
- return Create_Result (Input'Last - Start + 1, Needs_More, Input (Start .. Input'Last));
+ return (Input'Last, Needs_More);
else
- return Create_Result (Number, Success, Input (Start .. Start + Number - 1));
+ return (Start + Number - 1, Success);
end if;
end Take;
@@ -455,7 +577,7 @@ package body Packrat.Lexer is
else
Status := Success;
end if;
- return Create_Result (Finish - Start, Status, Input (Start .. Finish - 1));
+ return (Finish - 1, Status);
end Take_While;
@@ -478,7 +600,7 @@ package body Packrat.Lexer is
else
Status := Success;
end if;
- return Create_Result (Finish - Start, Status, Input (Start .. Finish - 1));
+ return (Finish - 1, Status);
end Take_Until;
@@ -493,7 +615,7 @@ package body Packrat.Lexer is
if Start > Input'Last then
return Empty_Fail;
elsif Input (Start) = EOL_Item then
- return Create_Result (1, Success, (1 => EOL_Item));
+ return (Start, Success);
else
return Empty_Fail;
end if;
@@ -508,7 +630,7 @@ package body Packrat.Lexer is
if Start > Input'Last then
return Empty_Fail;
elsif Input (Start) = EOF_Item then
- return Create_Result (1, Success, (1 => EOF_Item));
+ return (Start, Success);
else
return Empty_Fail;
end if;
diff --git a/src/packrat-lexer.ads b/src/packrat-lexer.ads
index 2d152bf..0cd5c78 100644
--- a/src/packrat-lexer.ads
+++ b/src/packrat-lexer.ads
@@ -2,7 +2,8 @@
private with
- Ada.Containers.Vectors;
+ Ada.Containers.Vectors,
+ Ada.Containers.Ordered_Sets;
generic
@@ -16,7 +17,7 @@ generic
package Packrat.Lexer is
- type Combinator_Result is new Ada.Finalization.Controlled with private;
+ type Combinator_Result is private;
type Combinator is access function
(Input : in Element_Array;
@@ -25,10 +26,6 @@ package Packrat.Lexer is
type Combinator_Array is array (Positive range <>) of Combinator;
- function "="
- (Left, Right : in Combinator_Result)
- return Boolean;
-
@@ -39,16 +36,19 @@ package Packrat.Lexer is
- type Lexer_Component is access procedure
+ type Component_Result is private;
+
+ type Component is access function
(Input : in Element_Array;
- Context : in out Lexer_Context);
+ Context : in out Lexer_Context)
+ return Component_Result;
- type Component_Array is array (Positive range <>) of Lexer_Component;
+ type Component_Array is array (Positive range <>) of Component;
- type Lexer_With_Input is access function
+ type With_Input is access function
return Element_Array;
@@ -60,9 +60,10 @@ package Packrat.Lexer is
(Input : in Element_Array;
Start : in Positive)
return Combinator_Result;
- procedure Stamp
+ function Stamp
(Input : in Element_Array;
- Context : in out Lexer_Context);
+ Context : in out Lexer_Context)
+ return Component_Result;
generic
Label : in Label_Enum;
@@ -70,9 +71,10 @@ package Packrat.Lexer is
(Input : in Element_Array;
Start : in Positive)
return Combinator_Result;
- procedure Ignore
+ function Ignore
(Input : in Element_Array;
- Context : in out Lexer_Context);
+ Context : in out Lexer_Context)
+ return Component_Result;
@@ -94,7 +96,7 @@ package Packrat.Lexer is
generic
Components : in Component_Array;
function Scan_With
- (Input : in Lexer_With_Input;
+ (Input : in With_Input;
Context : in out Lexer_Context)
return Gen_Tokens.Token_Array;
@@ -112,7 +114,7 @@ package Packrat.Lexer is
Pad_In : in Element;
Pad_Out : in Gen_Tokens.Token;
procedure Scan_Set_With
- (Input : in Lexer_With_Input;
+ (Input : in With_Input;
Context : in out Lexer_Context;
Output : out Gen_Tokens.Token_Array);
@@ -256,55 +258,96 @@ package Packrat.Lexer is
private
- type Element_Array_Access is access Element_Array;
+ package Token_Vectors is new Ada.Containers.Vectors
+ (Index_Type => Positive,
+ Element_Type => Gen_Tokens.Token,
+ "=" => Gen_Tokens."=");
+
+
+
+
+ type Element_Array_Access is access all Element_Array;
Empty_Array : Element_Array (1 .. 0);
- type Combinator_Result is new Ada.Finalization.Controlled with record
- Length : Natural;
+ package Label_Vectors is new Ada.Containers.Vectors
+ (Index_Type => Positive,
+ Element_Type => Label_Enum);
+
+
+
+
+ package Label_Sets is new Ada.Containers.Ordered_Sets
+ (Element_Type => Label_Enum);
+
+
+
+
+ type Combinator_Result is record
+ Finish : Natural;
Status : Result_Status;
- Value : Element_Array_Access;
end record;
- overriding procedure Initialize
- (This : in out Combinator_Result);
+ Empty_Fail : constant Combinator_Result :=
+ (Finish => 0,
+ Status => Failure);
- overriding procedure Adjust
- (This : in out Combinator_Result);
- overriding procedure Finalize
- (This : in out Combinator_Result);
- Empty_Fail : constant Combinator_Result :=
- (Ada.Finalization.Controlled with
- Length => 0,
- Status => Failure,
- Value => null);
+ type Component_Result is (Component_Failure, Component_Success);
- package Token_Vectors is new Ada.Containers.Vectors
- (Index_Type => Positive,
- Element_Type => Gen_Tokens.Token,
- "=" => Gen_Tokens."=");
type Lexer_Context is new Ada.Finalization.Controlled with record
- Result_So_Far : Token_Vectors.Vector;
- Position : Positive;
- Status : Result_Status;
- Pass_Forward : Element_Array_Access;
+ Result_So_Far : Token_Vectors.Vector;
+ Position : Positive;
+ Offset : Natural;
+ Status : Result_Status;
+ Pass_Forward : Element_Array_Access;
+ Empty_Labels : Label_Sets.Set;
+ Error_Labels : Label_Vectors.Vector;
+ Allow_Incomplete : Boolean;
end record;
+ overriding procedure Initialize
+ (This : in out Lexer_Context);
+
+ overriding procedure Adjust
+ (This : in out Lexer_Context);
+
+ overriding procedure Finalize
+ (This : in out Lexer_Context);
+
Empty_Context : constant Lexer_Context :=
(Ada.Finalization.Controlled with
- Result_So_Far => Token_Vectors.Empty_Vector,
- Position => 1,
- Status => Success,
- Pass_Forward => null);
+ Result_So_Far => Token_Vectors.Empty_Vector,
+ Position => 1,
+ Offset => 0,
+ Status => Success,
+ Pass_Forward => null,
+ Empty_Labels => Label_Sets.Empty_Set,
+ Error_Labels => Label_Vectors.Empty_Vector,
+ Allow_Incomplete => True);
+
+
+
+
+ type Input_Container is new Ada.Finalization.Limited_Controlled with record
+ Data : Element_Array_Access;
+ Dealloc : Boolean;
+ end record;
+
+ overriding procedure Finalize
+ (This : in out Input_Container);
+
+ function Pass_Input
+ (Passed, Continuing : in Element_Array_Access)
+ return Input_Container;
end Packrat.Lexer;