⟦f1bf2f896⟧

TextFile

with Parameter_Parser_Defs;
use Parameter_Parser_Defs;

package body Parameter_Parser is

    type Option_Record;
    type Option is access Option_Record;
    type Option_Record is
        record
            Prefixable : Boolean;
            Kind : Option_Kind;
            Id : Option_Id;
            Name : Text;
            Value : Text;
            Next : Option;
        end record;

    type Iteration_Data;
    type Iteration is access Iteration_Data;
    type Iterator_Data is
        record
            Start : Iteration;
            Point : Iteration;
            Success : Boolean;
            Diagnosis : Image;
        end record;

    type Iteration_Data is
        record
            Status : Iteration_Status;
            Kind : Option_Kind;
            Name : Option;
            Value : Image;
            Diagnosis : Image;
            Next : Iteration;
        end record;

    Options : Option;
    Highest : Option_Id := From;
    Lowest : Option_Id := To;

    procedure Set_Status (Itn : Iteration;
                          Status : Iteration_Status;
                          Diagnosis : String := "") is
    begin
        Itn.Status := Status;

        if Diagnosis /= "" then
            Itn.Diagnosis := new String'(Diagnosis);
        end if;
    end Set_Status;




    function Find (Id : Option_Id; Start : Option := Options) return Option is
        Opt : Option := Start;
    begin
        while Opt /= null loop
            exit when Opt.Id = Id and then Opt.Kind /= Literal;
            Opt := Opt.Next;
        end loop;

        return Opt;
    end Find;

    function Find (Name : String;
                   Allow_Name_Prefix : Boolean := False;
                   Start : Option := Options) return Option is
        Opt : Option := Start;
    begin
        if Allow_Name_Prefix then
            while Opt /= null loop
                if Opt.Prefixable then
                    exit when May_Be (Name, Opt.Name.all);
                else
                    exit when Opt.Name.all = Name;
                end if;

                Opt := Opt.Next;
            end loop;
        else
            while Opt /= null loop
                exit when Opt.Name.all = Name;
                Opt := Opt.Next;
            end loop;
        end if;

        return Opt;
    end Find;

    procedure Define (Option : Option_Id;
                      Name : String := "";
                      Kind : Option_Kind := Unspecified;
                      Default_Value : String := "";
                      Allow_Name_Prefix : Boolean := False) is
    begin
        if Name'Length = 0 then
            Define (Option, Option_Id'Image (Option), Kind,
                    Default_Value, Allow_Name_Prefix);
        else
            declare
                Symbol : constant String := Normal (Name);
                Opt : Parameter_Parser.Option := Find (Symbol);
            begin
                if Opt = null then
                    Opt := new Option_Record;
                    Opt.Next := Options;
                    Options := Opt;

                    if Option > Highest then
                        Highest := Option;
                    elsif Option < Lowest then
                        Lowest := Option;
                    end if;
                end if;

                Opt.Prefixable := Allow_Name_Prefix;
                Opt.Kind := Kind;
                Opt.Id := Option;
                Opt.Name := new String'(Symbol);

                if Default_Value /= "" then
                    Opt.Value := new String'(Default_Value);
                end if;
            end;
        end if;
    end Define;

    procedure Undefine (Name : String) is
        Opt : Option := Find (Normal (Name));
        Prv : Option := Options;
    begin
        if Opt /= null then
            if Opt = Options then
                Options := Opt.Next;
            else
                while Prv /= null and then Prv.Next /= Opt loop
                    Prv := Prv.Next;
                end loop;

                Prv.Next := Opt.Next;
            end if;
        end if;
    end Undefine;

    procedure Undefine (From : Option_Id; To : Option_Id := Nil) is
        Opt : Option := Options;
        Prv : Option;
    begin
        if To = Nil then
            Undefine (From, From);
        else
            while Opt /= null loop
                if Opt.Id in From .. To then
                    if Prv = null then
                        Opt := Opt.Next;
                    else
                        Prv.Next := Opt.Next;
                    end if;
                else
                    Prv := Opt;
                end if;

                Opt := Opt.Next;
            end loop;
        end if;
    end Undefine;

    procedure Allow_Name_Prefix (Name : String; Value : Boolean := True) is
        Opt : Option := Find (Normal (Name));
    begin
        if Opt /= null then
            Opt.Prefixable := Value;
        end if;
    end Allow_Name_Prefix;

    procedure Allow_Name_Prefix (Value : Boolean := True;
                                 From : Option_Id := Nil;
                                 To : Option_Id := Nil) is
        Opt : Option := Options;
    begin
        if From = Nil then
            Allow_Name_Prefix (Value, Lowest, To);
        elsif To = Nil then
            Allow_Name_Prefix (Value, From, Highest);
        else
            while Opt /= null loop
                if Opt.Id in From .. To then
                    Opt.Prefixable := Value;
                end if;

                Opt := Opt.Next;
            end loop;
        end if;
    end Allow_Name_Prefix;

    function Find (Iter : Iterator; Name : Option_Id) return Iteration is
        Itn : Iteration;
    begin
        if Name = Nil then
            return Iter.Point;
        else
            Itn := Iter.Start;

            while Itn /= null loop
                exit when Itn.Name /= null and then Itn.Name.Id = Name;
                Itn := Itn.Next;
            end loop;

            return Itn;
        end if;
    end Find;

    function Is_Ok (Iter : Iterator; Name : Option_Id := Nil) return Boolean is
        Itn : Iteration := Find (Iter, Name);
    begin
        return Itn /= null and then Itn.Status = Ok;
    end Is_Ok;

    function Is_Present (Iter : Iterator; Name : Option_Id) return Boolean is
    begin
        return Find (Iter, Name) /= null;
    end Is_Present;

    function Diagnosis
                (Iter : Iterator; Name : Option_Id := Nil) return String is
        Itn : Iteration := Find (Iter, Name);
    begin
        if Itn = null then
            return Option_Id'Image (Name) & " has not been specified";
        else
            case Itn.Status is
                when Ok =>
                    return "";
                when Undefined_Name | Undefined_Enumeration | Undefined_Id =>
                    return "'" & Itn.Diagnosis.all &
                              "' denotes no defined option";
                when Ambiguous_Name | Ambiguous_Enumeration =>
                    return "'" & Itn.Diagnosis.all & "' is ambiguous";
                when Literal_Has_Value =>
                    return "The literal '" & Itn.Value.all &
                              "' can't be assigned a value";
                when Has_No_Value =>
                    return "Option " & Itn.Name.Name.all & " must have a value";
                when Tilded_Value =>
                    return "Option " & Itn.Name.Name.all &
                              " has both a '~' and a value";
                when Tilded_Literal =>
                    return "The literal '" & Itn.Value.all & "' has a '~'";
                when Missing_Name =>
                    if Itn.Value = null then
                        return "An option name is expected where '" &
                                  Itn.Diagnosis.all & "' now appears";
                    else
                        return "An option name is expected where '" &
                                  Itn.Diagnosis.all & ' ' &
                                  Itn.Value.all & " now appears";
                    end if;
                when Malformed_Boolean =>
                    return ''' & Itn.Value.all &
                              "' is not a valid Boolean value";
                when Malformed_Integer =>
                    return ''' & Itn.Value.all &
                              "' is not a valid integer value";
                when Malformed_Float =>
                    return ''' & Itn.Value.all &
                              "' is not a valid float value; " &
                              Itn.Diagnosis.all;
                when others =>
                    if Itn.Diagnosis /= null then
                        return Iteration_Status'Image (Itn.Status) &
                                  ' ' & Itn.Diagnosis.all;
                    else
                        return Iteration_Status'Image (Itn.Status);
                    end if;
            end case;
        end if;
    end Diagnosis;

    function Done (Iter : Iterator) return Boolean is
    begin
        return Iter.Point = null;
    end Done;

    procedure Next (Iter : in out Iterator) is
    begin
        if Iter.Point /= null then
            Iter.Point := Iter.Point.Next;
        end if;
    end Next;

    procedure Reset (Iter : in out Iterator) is
    begin
        Iter.Point := Iter.Start;
    end Reset;

    function Name (Iter : Iterator) return Option_Id is
        Itn : Iteration := Iter.Point;
    begin
        if Itn /= null and then Itn.Name /= null then
            return Itn.Name.Id;
        else
            return Nil;
        end if;
    end Name;

    function Name (Iter : Iterator; Name : Option_Id := Nil) return String is
        Itn : Iteration := Find (Iter, Name);
    begin
        if Itn /= null then
            if Itn.Name /= null then
                return Itn.Name.Name.all;
            elsif Itn.Status = Undefined_Name then
                return Itn.Diagnosis.all;
            end if;
        end if;

        return "";
    end Name;

    function Has_Value
                (Iter : Iterator; Name : Option_Id := Nil) return Boolean is
        Itn : Iteration := Find (Iter, Name);
    begin
        return Itn /= null and then Itn.Value /= null;
    end Has_Value;

    function Get_Option
                (Iter : Iterator; Name : Option_Id := Nil) return Option is
        Itn : Iteration := Find (Iter, Name);
    begin
        if Itn /= null then
            return Itn.Name;
        else
            return null;
        end if;
    end Get_Option;

    function Get_Image
                (Itn : Iteration; Default : String := "") return String is
    begin
        if Itn = null or else Itn.Value = null then
            return Default;
        else
            return Clean (Itn.Value.all);
        end if;
    end Get_Image;

    function Get_Image (Iter : Iterator;
                        Name : Option_Id := Nil;
                        Default : String := "") return String is
    begin
        return Get_Image (Find (Iter, Name), Default);
    end Get_Image;

    function Kind (Iter : Iterator; Name : Option_Id := Nil)
                  return Option_Kind is
        Itn : Iteration := Find (Iter, Name);
        Image : constant String := Get_Image (Itn);
    begin
        if Itn /= null and then Itn.Status = Ok then
            return Itn.Kind;
        else
            return Unspecified;
        end if;
    end Kind;

    package body Enumerated_Value is
        procedure Enum_Ops_Unique_Prefix is new Unique_Prefix (T);

        function Get_Enumeration (Iter : Iterator;
                                  Name : Option_Id := Parameter_Parser.Nil;
                                  Allow_Value_Prefix : Boolean := True;
                                  Default : T := Nil) return T is
            Itn : Iteration := Find (Iter, Name);
            Image : constant String := Get_Image (Iter, Name);
            Enum : T;
            Prefix, Unique : Boolean;
        begin
            if Itn /= null and then Itn.Status = Ok then
                Enum_Ops_Unique_Prefix (Image, Enum, Prefix, Unique);

                if not Prefix and then not Unique then
                    Set_Status (Itn, Undefined_Enumeration, Image);

                elsif not Unique then
                    Set_Status (Itn, Ambiguous_Enumeration, Image);

                elsif Prefix and not Allow_Value_Prefix then
                    Set_Status (Itn, Undefined_Enumeration, Image);

                else
                    return Enum;
                end if;
            end if;

            return Default;
        end Get_Enumeration;
    begin
        if Id /= Parameter_Parser.Nil then
            for I in T loop
                if I /= Nil then
                    Define (Id, T'Image (I), Literal, "", Allow_Name_Prefix);
                end if;
            end loop;
        end if;
    end Enumerated_Value;

    package Booleans is new Enumerated_Value (Boolean);

    function Get_Boolean (Iter : Iterator;
                          Name : Option_Id := Nil;
                          Default : Boolean := False) return Boolean is
    begin
        return Booleans.Get_Enumeration (Iter, Name, True, Default);
    end Get_Boolean;

    function Get_Integer (Itn : Iteration; Default : Integer := Integer'Last)
                         return Integer is
    begin
        return Integer'Value (Get_Image (Itn));
    exception
        when Constraint_Error =>
            Itn.Status := Malformed_Integer;
            return Default;
    end Get_Integer;

    function Get_Integer (Iter : Iterator;
                          Name : Option_Id := Nil;
                          Default : Integer := Integer'Last) return Integer is
        Itn : Iteration := Find (Iter, Name);
    begin
        if Itn /= null then
            return Get_Integer (Itn, Default);
        end if;

        return Default;
    end Get_Integer;

    function Get_Float (Itn : Iteration; Default : Float := Float'Safe_Large)
                       return Float;

    function Get_Float (Iter : Iterator;
                        Name : Option_Id := Nil;
                        Default : Float := Float'Safe_Large) return Float is
        Itn : Iteration := Find (Iter, Name);
    begin
        if Itn /= null then
            return Get_Float (Itn, Default);
        end if;

        return Default;
    end Get_Float;

    function Get_Value (Iter : Iterator;
                        Name : Option_Id := Parameter_Parser.Nil;
                        Default : T := Nil) return T is
        Itn : Iteration := Find (Iter, Name);
        Image : constant String := Get_Image (Itn);
    begin
        if Itn = null then
            return Default;
        end if;

        declare
            V : constant T := Value (Image);
        begin
            if V = Nil then
                Set_Status (Itn, Malformed_Generic_Value, Diagnosis (Image));
                return Default;
            end if;

            return V;
        end;
    end Get_Value;

    package Kinds is new Enumerated_Value (Option_Kind);

    function Parse (Parameter : String) return Iterator is
        Success : Boolean;
        Iter : Iterator;
    begin
        Parse (Parameter, Iter, Success);
        return Iter;
    end Parse;

    function Is_Successful (Iter : Iterator) return Boolean is
    begin
        return Iter.Success;
    end Is_Successful;


    function Get_Float (Itn : Iteration; Default : Float := Float'Safe_Large)
                       return Float is
        Buffer : constant String := Get_Image (Itn) & ' ';
        Result : Float := Default;
        Last : Integer;
    begin
        Float_Io.Get (From => Buffer, Item => Result, Last => Last);
        return Result;
    exception
        when others =>
            Itn.Status := Malformed_Float;
            Itn.Diagnosis := new String'("cannot convert float value");
            return Default;
    end Get_Float;

    procedure Parse (Parameter : String;
                     Options : out Iterator;
                     Success : out Boolean) is separate;

begin
    for I in From .. To loop
        Define (I, Allow_Name_Prefix => True);
    end loop;

    declare
        Values : Iterator;
        Opt : Option;
        Successful : Boolean;
    begin
        Parse (Option_Kinds, Values, Successful);

        while not Done (Values) loop
            if Is_Ok (Values) and then Has_Value (Values) then
                Opt := Get_Option (Values);
                Opt.Kind := Kinds.Get_Enumeration (Values);
            end if;

            Next (Values);
        end loop;

        Parse (Default_Values, Values, Successful);

        while not Done (Values) loop
            if Is_Ok (Values) and then Has_Value (Values) then
                Opt := Get_Option (Values);
                Opt.Value := new String'(Get_Image (Values));
            end if;

            Next (Values);
        end loop;

        Parse (Alternate_Names, Values, Successful);

        while not Done (Values) loop
            if Has_Value (Values) then
                Opt := Get_Option (Values);

                if Opt.Value /= null then
                    Define (Opt.Id, Get_Image (Values), Opt.Kind,
                            Opt.Value.all, Opt.Prefixable);
                else
                    Define (Opt.Id, Get_Image (Values),
                            Opt.Kind, "", Opt.Prefixable);
                end if;
            end if;

            Next (Values);
        end loop;
    end;

end Parameter_Parser;
DataMuseum.dk

Rational R1000/400 Tapes

⟦f1bf2f896⟧ TextFile

Derivation

TextFile
