|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 27648 (0x6c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Enumerated_Value, package body Parameter_Parser, seg_0046af
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦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 pt /= 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;
nblk1=1a
nid=0
hdr6=34
[0x00] rec0=27 rec1=00 rec2=01 rec3=044
[0x01] rec0=04 rec1=00 rec2=1a rec3=01a
[0x02] rec0=22 rec1=00 rec2=02 rec3=024
[0x03] rec0=00 rec1=00 rec2=15 rec3=002
[0x04] rec0=1d rec1=00 rec2=03 rec3=012
[0x05] rec0=1c rec1=00 rec2=04 rec3=042
[0x06] rec0=01 rec1=00 rec2=19 rec3=034
[0x07] rec0=22 rec1=00 rec2=05 rec3=00c
[0x08] rec0=1f rec1=00 rec2=06 rec3=018
[0x09] rec0=21 rec1=00 rec2=07 rec3=008
[0x0a] rec0=14 rec1=00 rec2=08 rec3=00c
[0x0b] rec0=12 rec1=00 rec2=09 rec3=060
[0x0c] rec0=20 rec1=00 rec2=0a rec3=014
[0x0d] rec0=20 rec1=00 rec2=0b rec3=030
[0x0e] rec0=1f rec1=00 rec2=0c rec3=05c
[0x0f] rec0=00 rec1=00 rec2=18 rec3=00c
[0x10] rec0=19 rec1=00 rec2=0d rec3=026
[0x11] rec0=01 rec1=00 rec2=17 rec3=01e
[0x12] rec0=1f rec1=00 rec2=0e rec3=004
[0x13] rec0=1b rec1=00 rec2=0f rec3=072
[0x14] rec0=22 rec1=00 rec2=10 rec3=02e
[0x15] rec0=00 rec1=00 rec2=16 rec3=010
[0x16] rec0=1f rec1=00 rec2=11 rec3=018
[0x17] rec0=00 rec1=00 rec2=14 rec3=024
[0x18] rec0=22 rec1=00 rec2=12 rec3=066
[0x19] rec0=14 rec1=00 rec2=13 rec3=000
tail 0x21500493a815c66daa4fc 0x42a00088462061e03