-- This source is licensed under the Sunset License v1.0 with Packrat.Errors; package body Packrat.Lexers is function Join (Left, Right : in Combinator_Result) return Combinator_Result is begin if Left.Status = Success or Left.Status = Optional_More then return (Integer'Max (Left.Finish, Right.Finish), Right.Status); elsif Left.Status = Needs_More then return (Left.Finish, Failure); else return Left; end if; end Join; procedure Tidy_Context (Details : in out Lexer_Context; Number_Comp : in Ada.Containers.Count_Type) is begin Details.Pass_Forward.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 : Packrat.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 := +Traits.Label_Enum'Image (Label_List.Element (I)); Error_Info_List (I).Position := Position; end loop; raise Lexer_Error with Packrat.Errors.Encode_Array (Error_Info_List); end Raise_Lexer_Error; function Token_Vector_To_Array (Input_Vector : in Token_Vectors.Vector) return Traits.Tokens.Token_Array is Result_Array : Traits.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; procedure Token_Vector_To_Array (Input_Vector : in Token_Vectors.Vector; Padding : in Traits.Tokens.Token_Type; Output_Array : out Traits.Tokens.Token_Array) is begin for N in Integer range 1 .. Output_Array'Length loop if N <= Integer (Input_Vector.Length) then Output_Array (Output_Array'First + N - 1) := Input_Vector.Element (N); else Output_Array (Output_Array'First + N - 1) := Padding; end if; end loop; end Token_Vector_To_Array; function Slide (Input : in Traits.Element_Array) return Traits.Element_Array is subtype Slider is Traits.Element_Array (1 .. Input'Length); begin return Slider (Input); end Slide; procedure Internal_Scan_Core (Input : in Traits.Element_Array; Context : in out Lexer_Context; Components : in Component_Array) is Raise_Error : Boolean; begin Raise_Error := True; for C of Components loop if C (Input, 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 Internal_Scan_Core; package body Scan_Parts is Context : Lexer_Context := Empty_Context; function Scan (Input : in Traits.Element_Array) return Traits.Tokens.Token_Array is Real_Input : Input_Holders.Holder; begin if not Context.Pass_Forward.Is_Empty then Real_Input.Replace_Element (Slide (Context.Pass_Forward.Element) & Input); else Real_Input.Replace_Element (Slide (Input)); end if; Tidy_Context (Context, Components'Length); Context.Result_So_Far.Clear; Context.Allow_Incomplete := Input'Length > 0; while Context.Status = Success and Context.Position <= Real_Input.Element'Length loop Internal_Scan_Core (Real_Input.Element, Context, Components); end loop; return Token_Vector_To_Array (Context.Result_So_Far); end Scan; procedure Reset is begin Context := Empty_Context; end Reset; end Scan_Parts; package body Scan_Once is Context : Lexer_Context := Empty_Context; function Scan (Input : in Traits.Element_Array) return Traits.Tokens.Token_Array is Real_Input : Input_Holders.Holder; begin if not Context.Pass_Forward.Is_Empty then Real_Input.Replace_Element (Slide (Context.Pass_Forward.Element) & Input); else Real_Input.Replace_Element (Slide (Input)); end if; Tidy_Context (Context, Components'Length); Context.Result_So_Far.Clear; Context.Allow_Incomplete := False; while Context.Status = Success and Context.Position <= Real_Input.Element'Length loop Internal_Scan_Core (Real_Input.Element, Context, Components); end loop; return Token_Vector_To_Array (Context.Result_So_Far); end Scan; procedure Reset is begin Context := Empty_Context; end Reset; end Scan_Once; package body Scan_With is Context : Lexer_Context := Empty_Context; function Scan (Input : in With_Input) return Traits.Tokens.Token_Array is Real_Input : Input_Holders.Holder; Empty_Input : Boolean; begin Context.Result_So_Far.Clear; loop Real_Input.Replace_Element (Slide (Input.all)); Empty_Input := Real_Input.Element'Length = 0; if not Context.Pass_Forward.Is_Empty then Real_Input.Replace_Element (Slide (Context.Pass_Forward.Element) & Real_Input.Element); end if; Tidy_Context (Context, Components'Length); Context.Allow_Incomplete := not Empty_Input; while Context.Status = Success and Context.Position <= Real_Input.Element'Length loop Internal_Scan_Core (Real_Input.Element, Context, Components); end loop; if Empty_Input then exit; end if; end loop; return Token_Vector_To_Array (Context.Result_So_Far); end Scan; procedure Reset is begin Context := Empty_Context; end Reset; end Scan_With; package body Scan_Set is Context : Lexer_Context := Empty_Context; procedure Scan (Input : in Traits.Element_Array; Output : out Traits.Tokens.Token_Array) is Real_Input : Input_Holders.Holder; begin if not Context.Pass_Forward.Is_Empty then Real_Input.Replace_Element (Slide (Context.Pass_Forward.Element) & Input); else Real_Input.Replace_Element (Input); end if; Tidy_Context (Context, Components'Length); Context.Result_So_Far.Clear; Context.Allow_Incomplete := not (Input'Length = 0 or else Input (Input'First) = Pad_In); while Context.Status = Success and then Integer (Context.Result_So_Far.Length) < Output'Length and then Context.Position <= Real_Input.Element'Length and then Real_Input.Element (Context.Position) /= Pad_In loop Internal_Scan_Core (Real_Input.Element, Context, Components); end loop; if Integer (Context.Result_So_Far.Length) = Output'Length then Context.Pass_Forward.Replace_Element (Real_Input.Element (Context.Position .. Real_Input.Element'Last)); end if; Token_Vector_To_Array (Context.Result_So_Far, Pad_Out, Output); end Scan; procedure Reset is begin Context := Empty_Context; end Reset; end Scan_Set; package body Scan_Set_With is Context : Lexer_Context := Empty_Context; procedure Scan (Input : in With_Input; Output : out Traits.Tokens.Token_Array) is Real_Input : Input_Holders.Holder; Empty_Input : Boolean; begin Context.Result_So_Far.Clear; loop Real_Input.Replace_Element (Input.all); Empty_Input := Real_Input.Element'Length = 0 or else Real_Input.Element (Real_Input.Element'First) = Pad_In; if not Context.Pass_Forward.Is_Empty then Real_Input.Replace_Element (Slide (Context.Pass_Forward.Element) & Real_Input.Element); end if; Tidy_Context (Context, Components'Length); Context.Allow_Incomplete := not Empty_Input; while Context.Status = Success and then Integer (Context.Result_So_Far.Length) < Output'Length and then Context.Position <= Real_Input.Element'Length and then Real_Input.Element (Context.Position) /= Pad_In loop Internal_Scan_Core (Real_Input.Element, Context, Components); end loop; if Empty_Input then exit; end if; if Integer (Context.Result_So_Far.Length) = Output'Length then Context.Pass_Forward.Replace_Element (Real_Input.Element (Context.Position .. Real_Input.Element'Last)); exit; end if; end loop; Token_Vector_To_Array (Context.Result_So_Far, Pad_Out, Output); end Scan; procedure Reset is begin Context := Empty_Context; end Reset; end Scan_Set_With; function Stamp (Input : in Traits.Element_Array; Context : in out Lexer_Context) return Component_Result is Current_Result : Combinator_Result := Combo (Input, Context.Position); begin 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 (Traits.Tokens.Create (Label, Context.Position + 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.Replace_Element (Input (Context.Position .. Current_Result.Finish)); Context.Empty_Labels.Clear; end if; Context.Error_Labels.Clear; return Component_Success; end Stamp; function Discard (Input : in Traits.Element_Array; Context : in out Lexer_Context) return Component_Result is Current_Result : Combinator_Result := Combo (Input, Context.Position); begin 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.Replace_Element (Input (Context.Position .. Current_Result.Finish)); Context.Empty_Labels.Clear; end if; Context.Error_Labels.Clear; return Component_Success; end Discard; function Sequence (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is Result : Combinator_Result := (0, Success); Position : Positive := Start; begin if Start > Input'Last then return Empty_Fail; end if; for C of Params loop if Position > Input'Last then Result.Status := Needs_More; exit; end if; Result := Join (Result, C (Input, Position)); exit when Result.Status = Failure; Position := Result.Finish + 1; end loop; return Result; end Sequence; function Count (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is Result : Combinator_Result := (0, Success); Position : Positive := Start; begin if Start > Input'Last then return Empty_Fail; end if; for I in Integer range 1 .. Number loop if Position > Input'Last then Result.Status := Needs_More; exit; end if; Result := Join (Result, Param (Input, Position)); exit when Result.Status = Failure; Position := Result.Finish + 1; end loop; return Result; end Count; function Many (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is Result : Combinator_Result := (0, Success); Temp : Combinator_Result; Position : Positive := Start; Counter : Natural := 0; begin if Start > Input'Last then return Empty_Fail; end if; loop exit when Position > Input'Last; Temp := Param (Input, Position); exit when Temp.Status = Failure or Temp.Status = Needs_More; Result := Join (Result, Temp); Counter := Counter + 1; Position := Result.Finish + 1; end loop; if Counter < Minimum then if Position > Input'Last or Temp.Status = Needs_More then Result.Status := Needs_More; else Result.Status := Failure; end if; elsif Position > Input'Last or Temp.Status = Needs_More then Result.Status := Optional_More; else Result.Status := Success; end if; return Result; end Many; function Many_Until (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is Result : Combinator_Result := (0, Success); Temp : Combinator_Result; Position : Positive := Start; Counter : Natural := 0; begin if Start > Input'Last then return Empty_Fail; end if; loop exit when Position > Input'Last; Temp := Param (Input, Position); exit when Temp.Status = Failure or Temp.Status = Needs_More or Test (Input (Position)); Result := Join (Result, Temp); Counter := Counter + 1; Position := Result.Finish + 1; end loop; if Counter < Minimum then if Position > Input'Last or Temp.Status = Needs_More then Result.Status := Needs_More; else Result.Status := Failure; end if; elsif Position > Input'Last then Result.Status := Needs_More; elsif Temp.Status = Needs_More and Test (Input (Position)) then Result.Status := Optional_More; elsif Test (Input (Position)) then Result.Status := Success; else Result.Status := Failure; end if; return Result; end Many_Until; function Satisfy (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is begin if Start > Input'Last then return Empty_Fail; elsif Test (Input (Start)) then return (Start, Success); else return Empty_Fail; end if; end Satisfy; function Satisfy_With (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is begin if Start > Input'Last then return Empty_Fail; elsif Test (Change (Input (Start))) then return (Start, Success); else return Empty_Fail; end if; end Satisfy_With; function Match (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is begin if Start > Input'Last then return Empty_Fail; elsif Input (Start) = Item then return (Start, Success); else return Empty_Fail; end if; end Match; function Match_With (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is begin if Start > Input'Last then return Empty_Fail; elsif Change (Input (Start)) = Item then return (Start, Success); else return Empty_Fail; end if; end Match_With; function Multimatch (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is Current_Offset : Natural := 0; begin if Items'Length = 0 then return (0, Success); end if; if Input'Last - Start + 1 <= 0 then return Empty_Fail; end if; while Input (Start + Current_Offset) = Items (Items'First + Current_Offset) loop if Items'First + Current_Offset = Items'Last then return (Start + Current_Offset, Success); elsif Start + Current_Offset = Input'Last then return (Start + Current_Offset, Needs_More); end if; Current_Offset := Current_Offset + 1; end loop; if Current_Offset = 0 then return Empty_Fail; else return (Start + Current_Offset - 1, Failure); end if; end Multimatch; function Take (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is begin if Start > Input'Last then return Empty_Fail; elsif Start + Number - 1 > Input'Last then return (Input'Last, Needs_More); else return (Start + Number - 1, Success); end if; end Take; function Take_While (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is Finish : Positive := Start; Status : Result_Status; begin if Start > Input'Last or else not Test (Input (Start)) then return Empty_Fail; end if; while Finish <= Input'Last and then Test (Input (Finish)) loop Finish := Finish + 1; end loop; if Finish > Input'Last then Status := Optional_More; else Status := Success; end if; return (Finish - 1, Status); end Take_While; function Take_Until (Input : in Traits.Element_Array; Start : in Positive) return Combinator_Result is Finish : Positive := Start; Status : Result_Status; begin if Start > Input'Last or else Test (Input (Start)) then return Empty_Fail; end if; while Finish <= Input'Last and then not Test (Input (Finish)) loop Finish := Finish + 1; end loop; if Finish > Input'Last then Status := Optional_More; else Status := Success; end if; return (Finish - 1, Status); end Take_Until; end Packrat.Lexers;