DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 17582 (0x44ae) Types: TextFile Names: »B«
└─⟦5829e5ed5⟧ Bits:30000534 8mm tape, Rational 1000, RCI 2_0_5 └─ ⟦c9a165082⟧ »DATA« └─⟦2162db02b⟧ └─⟦this⟧
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;