path: root/src/packrat-lexer.adb

with

    Ada.Unchecked_Deallocation;


package body Packrat.Lexer is


    procedure Free_Array is new Ada.Unchecked_Deallocation
        (Object => Element_Array, Name => Element_Array_Access);


    procedure Initialize
           (This : in out Combinator_Result) is
    begin
        null;
    end Initialize;


    procedure Adjust
           (This : in out Combinator_Result) is
    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;
        end if;
    end Adjust;


    procedure Finalize
           (This : in out Combinator_Result) is
    begin
        if This.Value /= null then
            Free_Array (This.Value);
        end if;
    end Finalize;





    function "="
           (Left, Right : in Combinator_Result)
        return Boolean
    is
        Left_Valsize, Right_Valsize : Natural;
    begin
        if Left.Value = null then
            Left_Valsize := 0;
        else
            Left_Valsize := Left.Value.all'Length;
        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 "=";





    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;
    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;
        elsif Left.Status = Needs_More then
            Merge := Left;
            Merge.Status := Failure;
            return Merge;
        else
            return Left;
        end if;
    end Join;





    procedure Stamp
           (Input   : in     Element_Array;
            Context : in out Lexer_Context) is
    begin
        null;
    end Stamp;


    procedure Ignore
           (Input   : in     Element_Array;
            Context : in out Lexer_Context) is
    begin
        null;
    end Ignore;





    function Scan
           (Input   : in     Element_Array;
            Context : in out Lexer_Context)
        return Gen_Tokens.Token_Array
    is
        Result : Gen_Tokens.Token_Array (1 .. 0);
    begin
        return Result;
    end Scan;


    procedure Scan_Set
           (Input   : in     Element_Array;
            Context : in out Lexer_Context;
            Output  :    out Gen_Tokens.Token_Array) is
    begin
        null;
    end Scan_Set;


    function Scan_Only
           (Input   : in     Element_Array;
            Context : in out Lexer_Context)
        return Gen_Tokens.Token_Array
    is
        Result : Gen_Tokens.Token_Array (1 .. 0);
    begin
        return Result;
    end Scan_Only;


    procedure Scan_Set_Only
           (Input   : in     Element_Array;
            Context : in out Lexer_Context;
            Output  :    out Gen_Tokens.Token_Array) is
    begin
        null;
    end Scan_Set_Only;


    function Scan_With
           (Input   : in     Element_Array;
            Context : in out Lexer_Context)
        return Gen_Tokens.Token_Array
    is
        Result : Gen_Tokens.Token_Array (1 .. 0);
    begin
        return Result;
    end Scan_With;


    procedure Scan_Set_With
           (Input   : in     Element_Array;
            Context : in out Lexer_Context;
            Output  :    out Gen_Tokens.Token_Array) is
    begin
        null;
    end Scan_Set_With;





    function Sequence
           (Input : in Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Result : Combinator_Result := Create_Result (0, Success, Empty_Array);
        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 := Start + Result.Length;
        end loop;
        return Result;
    end Sequence;


    function Count
           (Input : in Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Result : Combinator_Result := Create_Result (0, Success, Empty_Array);
        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 := Start + Result.Length;
        end loop;
        return Result;
    end Count;


    function Many
           (Input : in Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Result : Combinator_Result := Create_Result (0, Success, Empty_Array);
        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 := Start + Result.Length;
        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 Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Result : Combinator_Result := Create_Result (0, Success, Empty_Array);
        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 := Start + Result.Length;
        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 Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Test (Input (Start)) then
            return Create_Result (1, Success, (1 => Input (Start)));
        else
            return Empty_Fail;
        end if;
    end Satisfy;


    function Satisfy_With
           (Input : in 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 Create_Result (1, Success, (1 => Input (Start)));
        else
            return Empty_Fail;
        end if;
    end Satisfy_With;


    function Match
           (Input : in Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Input (Start) = Item then
            return Create_Result (1, Success, (1 => Item));
        else
            return Empty_Fail;
        end if;
    end Match;


    function Match_With
           (Input : in 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 Create_Result (1, Success, (1 => Input (Start)));
        else
            return Empty_Fail;
        end if;
    end Match_With;


    function Multimatch
           (Input : in Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Current_Offset : Natural := 0;
    begin
        if Items'Length = 0 then
            return Create_Result (0, Success, Empty_Array);
        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 Create_Result (Current_Offset + 1, Success, Items);
            elsif Start + Current_Offset = Input'Last then
                return Create_Result (Current_Offset + 1, Needs_More, Input (Start .. Input'Last));
            end if;
            Current_Offset := Current_Offset + 1;
        end loop;
        return Create_Result (Current_Offset, Failure, Input (Start .. Start + Current_Offset - 1));
    end Multimatch;


    function Take
           (Input : in 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 Create_Result (Input'Last - Start + 1, Needs_More, Input (Start .. Input'Last));
        else
            return Create_Result (Number, Success, Input (Start .. Start + Number - 1));
        end if;
    end Take;


    function Take_While
           (Input : in 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 Create_Result (Finish - Start, Status, Input (Start .. Finish - 1));
    end Take_While;


    function Take_Until
           (Input : in 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 Create_Result (Finish - Start, Status, Input (Start .. Finish - 1));
    end Take_Until;





    function Line_End
           (Input : in Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Input (Start) = EOL_Item then
            return Create_Result (1, Success, (1 => EOL_Item));
        else
            return Empty_Fail;
        end if;
    end Line_End;


    function Input_End
           (Input : in Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Input (Start) = EOF_Item then
            return Create_Result (1, Success, (1 => EOF_Item));
        else
            return Empty_Fail;
        end if;
    end Input_End;


end Packrat.Lexer;