|
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: 32768 (0x8000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Constraint_Utilities, seg_00461e
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Io;
with Expression_Utilities;
with Size_Utilities;
with String_Utilities;
with Type_Information;
with Bounds_Utilities;
with Ada_Program;
with Declarations;
with Names_And_Expressions;
package body Constraint_Utilities is
package Ada renames Ada_Program;
package Expressions renames Names_And_Expressions;
package Float_Conversion is new Io.Float_Io (Float);
Others_Choice_Found : exception;
function Another_Object
(Original_Decl : Ada_Program.Element) return Object is
Obj : Object (Kind => Other_Object);
begin
Obj.Decl := Original_Decl;
return Obj;
end Another_Object;
function Is_Character
(Type_Def : Type_Information.Type_Definition) return Boolean is
Last : Ada.Element := Type_Information.Last_Constraint (Type_Def);
begin
return String_Utilities.Equal (Ada.Image (Last), "CHARACTER") or else
String_Utilities.Equal
(Declarations.Name (Ada.Parent (Last)), "CHARACTER");
end Is_Character;
function Is_String (Array_Type_Def : Type_Information.Type_Definition)
return Boolean is
Component_Type : Type_Information.Subtype_Indication :=
Type_Information.Component_Type (Array_Type_Def);
begin
return Is_Character (Component_Type);
end Is_String;
function Compute_Array
(Type_Def : Type_Information.Type_Definition) return Object is
Index_Constraints : Ada.Element_Iterator :=
Type_Information.Index_Constraints (Type_Def);
Num_Elements : Size_Utilities.Long_Natural;
Static : Boolean;
begin
Size_Utilities.Number_Of_Elements
(Index_Constraints, Num_Elements, Static);
if Static then
if Is_String (Type_Def) then
return Object'(A_String_Object, Type_Def,
Natural (Num_Elements));
else
return Object'(An_Array_Object, Type_Def,
Natural (Num_Elements));
end if;
else
return Another_Object (Type_Def);
end if;
end Compute_Array;
procedure Non_Static_Value (For_Name_Expression : Ada_Program.Expression;
Value : out Long_Integer;
Has_Value : out Boolean) is
begin
Value := 0;
Has_Value := False;
end Non_Static_Value;
function Integer_Val is
new Expression_Utilities.Integer_Value (Non_Static_Value);
procedure Non_Static_Value (For_Name_Expression : Ada_Program.Expression;
Value : out Float;
Has_Value : out Boolean) is
begin
Value := 0.0;
Has_Value := False;
end Non_Static_Value;
function Float_Val is
new Expression_Utilities.Float_Value (Non_Static_Value);
procedure Non_Static_Value (For_Name_Expression : Ada_Program.Expression;
Value : out String;
Last : out Positive;
Has_Value : out Boolean) is
begin
Value := "";
Last := 1;
Has_Value := False;
end Non_Static_Value;
function String_Val is
new Expression_Utilities.String_Value (Non_Static_Value);
function Range_Object (A_Range : Type_Information.Range_Info;
Original_Decl : Ada_Program.Element) return Object is
Lbound_Expr, Ubound_Expr : Ada_Program.Element;
Lbound, Ubound : Long_Integer;
L_Bound, U_Bound : Float;
Type_Def : Type_Information.Type_Definition;
begin
Type_Information.Bounds (A_Range, Lbound_Expr, Ubound_Expr);
Type_Def := Expressions.Expression_Type (Lbound_Expr);
if String_Utilities.Equal (Ada_Program.Image (Type_Def),
"[universal_integer]") then
Lbound := Integer_Val (Lbound_Expr);
Ubound := Integer_Val (Ubound_Expr);
return Object'(An_Integer_Object, Original_Decl, Lbound, Ubound);
elsif String_Utilities.Equal
(Ada_Program.Image (Type_Def), "[universal_real]") then
L_Bound := Float_Val (Lbound_Expr);
U_Bound := Float_Val (Ubound_Expr);
return Object'(A_Float_Object, Original_Decl, L_Bound, U_Bound);
end if;
begin
case Type_Information.Kind
(Type_Information.Ground_Type (Type_Def)) is
when Type_Information.An_Integer_Type_Definition =>
Lbound := Integer_Val (Lbound_Expr);
Ubound := Integer_Val (Ubound_Expr);
return Object'(An_Integer_Object,
Original_Decl, Lbound, Ubound);
when Type_Information.A_Float_Type_Definition =>
L_Bound := Float_Val (Lbound_Expr);
U_Bound := Float_Val (Ubound_Expr);
return Object'(A_Float_Object, Original_Decl,
L_Bound, U_Bound);
when others =>
return Another_Object (Original_Decl);
end case;
exception
when Expression_Utilities.Not_Static =>
return Another_Object (Original_Decl);
end;
end Range_Object;
function Actual_String_Size
(Index_Constraints : Ada_Program.Element;
Original_Decl : Ada_Program.Element) return Object is
Ranges : Ada_Program.Element_Iterator :=
Type_Information.Discrete_Ranges (Index_Constraints);
A_Range : Ada_Program.Element;
Current_Size : Long_Integer;
Total_Elems : Long_Integer := 1;
Static : Boolean;
Lbound, Ubound : Long_Integer;
Lbound_Expr, Ubound_Expr : Names_And_Expressions.Expression;
begin
while not Ada_Program.Done (Ranges) loop
A_Range := Ada_Program.Value (Ranges);
Bounds_Utilities.Find_Range (The_Range => A_Range,
Lbound => Lbound,
Ubound => Ubound,
Static => Static,
Non_Static_Lbound => Lbound_Expr,
Non_Static_Ubound => Ubound_Expr);
if Static then
Current_Size := Ubound - Lbound + 1;
Total_Elems := Total_Elems * Current_Sie;
else
return Another_Object (Original_Decl);
end if;
Ada_Program.Next (Ranges);
end loop;
return Object'(A_String_Object, Original_Decl, Natural (Total_Elems));
end Actual_String_Size;
function Analyze
(Object_Decl : Declarations.Object_Declaration) return Object is
Type_Def : Ada.Element;
Type_Spec : Ada.Element;
Static : Boolean;
Ubound, Lbound : Long_Integer;
U_Bound, L_Bound : Float;
Constraint : Type_Information.Type_Constraint;
begin
if Declarations.Is_Subprogram_Formal (Object_Decl) or else
Declarations.Is_Generic_Formal (Object_Decl) then
Type_Def := Declarations.Type_Mark (Object_Decl);
Type_Spec := Declarations.Type_Specification
(Ada_Program.Definition (Type_Def));
else
Type_Def := Declarations.Object_Type (Object_Decl);
Type_Spec := Type_Information.Last_Constraint (Type_Def);
end if;
loop
case Type_Information.Kind (Type_Spec) is
when Type_Information.A_Subtype_Indication =>
Constraint := Type_Information.Constraint (Type_Spec);
case Type_Information.Constraint_Kind (Constraint) is
when Type_Information.A_Floating_Point_Constraint =>
Bounds_Utilities.Float_Range_Constraint_Bounds
(Type_Information.Floating_Point_Constraint
(Type_Spec), L_Bound, U_Bound, Static);
if Static then
return Object'(A_Float_Object, Object_Decl,
L_Bound, U_Bound);
else
return Another_Object (Object_Decl);
end if;
when Type_Information.A_Fixed_Point_Constraint =>
-- currently unimplemented
return Another_Object (Object_Decl);
when Type_Information.A_Simple_Range =>
return Range_Object (Constraint, Object_Decl);
when Type_Information.A_Range_Attribute =>
Bounds_Utilities.Integer_Range_Constraint_Bounds
(Type_Spec, Lbound, Ubound, Static);
if Static then
return Object'(An_Integer_Object,
Object_Decl, Lbound, Ubound);
else
return Another_Object (Object_Decl);
end if;
when Type_Information.An_Index_Constraint =>
return Actual_String_Size (Constraint, Object_Decl);
when others =>
return Another_Object (Object_Decl);
end case;
when Type_Information.An_Integer_Type_Definition =>
Bounds_Utilities.Integer_Range_Constraint_Bounds
(Type_Information.Integer_Constraint (Type_Spec),
Lbound, Ubound, Static);
if Static then
return Object'(An_Integer_Object,
Object_Decl, Lbound, Ubound);
else
return Another_Object (Object_Decl);
end if;
when Type_Information.A_Float_Type_Definition =>
Bounds_Utilities.Float_Range_Constraint_Bounds
(Type_Information.Floating_Point_Constraint (Type_Spec),
L_Bound, U_Bound, Static);
if Static then
return Object'(A_Float_Object, Object_Decl,
L_Bound, U_Bound);
else
return Another_Object (Object_Decl);
end if;
when Type_Information.An_Array_Type_Definition =>
return Compute_Array (Type_Spec);
when Type_Information.A_Derived_Type_Definition =>
Type_Spec := Type_Information.Last_Constraint
(Type_Information.Derived_From (Type_Spec));
-- loop on type that was derived
when Type_Information.A_Private_Type_Definition ..
Type_Information.A_Limited_Private_Type_Definition =>
Type_Spec := Declarations.Type_Specification (Type_Spec);
-- loop on private type specification
when others =>
return Another_Object (Object_Decl);
end case;
end loop;
exception
when others =>
return Another_Object (Object_Decl);
end Analyze;
function Another_Value (Expr : Ada_Program.Element) return Value is
Val : Value (Other_Value);
begin
Val.Expr := Expr;
return Val;
end Another_Value;
procedure Check_Choices (List : in out Ada.Element_Iterator) is
begin
while not Ada.Done (List) loop
case Type_Information.Choice_Kind (Ada.Value (List)) is
when Type_Information.Others_Choice =>
raise Others_Choice_Found;
when Type_Information.A_Discrete_Range =>
raise Others_Choice_Found;
when others =>
null;
end case;
Ada.Next (List);
end loop;
end Check_Choices;
function Compute_Aggregate (Agg : Ada.Expression) return Value is
Components : Ada.Element_Iterator := Expressions.Components (Agg);
Count : Natural := 0;
Choices : Ada.Element_Iterator;
begin
while not Ada.Done (Components) loop
Choices := Expressions.Component_Choices (Ada.Value (Components));
Check_Choices (Choices);
Count := Count + 1;
Ada.Next (Components);
end loop;
return Value'(An_Array_Aggregate, Agg, Count);
end Compute_Aggregate;
function Analyze (Value_Expression : Ada_Program.Expression) return Value is
Type_Def : Type_Information.Type_Definition;
Integer_Value : Long_Integer;
Float_Value : Float;
Static : Boolean;
begin
case Expressions.Kind (Value_Expression) is
when Expressions.An_Integer_Literal =>
return Value'(An_Integer_Value, Value_Expression,
Expressions.Static_Value (Value_Expression));
when Expressions.A_Real_Literal =>
return Value'(A_Float_Value, Value_Expression,
Expressions.Static_Value (Value_Expression));
when Expressions.A_String_Literal =>
declare
Val : constant String :=
Expressions.Static_Value (Value_Expression);
begin
return Value'(A_String_Value, Value_Expression, Val'Length);
end;
when Expressions.An_Aggregate =>
return Compute_Aggregate (Value_Expression);
when others =>
Type_Def := Expressions.Expression_Type (Value_Expression);
begin
case Type_Information.Kind
(Type_Information.Ground_Type (Type_Def)) is
when Type_Information.An_Integer_Type_Definition =>
return Value'(An_Integer_Value, Value_Expression,
Integer_Val (Value_Expression));
when Type_Information.A_Float_Type_Definition =>
return Value'(A_Float_Value, Value_Expression,
Float_Val (Value_Expression));
when Type_Information.An_Array_Type_Definition =>
declare
Val : constant String :=
String_Val (Value_Expression);
begin
return Value'(A_String_Value,
Value_Expression, Val'Length);
end;
when others =>
return Another_Value (Value_Expression);
end case;
exception
when Expression_Utilities.Not_Static =>
return Another_Value (Value_Expression);
end;
end case;
exception
when others =>
return Another_Value (Value_Expression);
end Analyze;
function Match (A_Value : Value; In_Object : Object) return Boolean is
begin
case A_Value.Kind is
when A_String_Value =>
case In_Object.Kind is
when A_String_Object =>
return True;
when others =>
return False;
end case;
when An_Array_Aggregate =>
case In_Object.Kind is
when An_Array_Object =>
return True;
when others =>
return False;
end case;
when An_Integer_Value =>
case In_Object.Kind is
when An_Integer_Object =>
return True;
when others =>
return False;
end case;
when A_Float_Value =>
case In_Object.Kind is
when A_Float_Object =>
return True;
when others =>
return False;
end case;
when Other_Value =>
case In_Object.Kind is
when Other_Object =>
return True;
when others =>
return False;
end case;
end case;
end Match;
function Fits (A_Value : Value; In_Object : Object) return Boolean is
begin
if Match (A_Value, In_Object) then
case A_Value.Kind is
when A_String_Value | An_Array_Aggregate =>
return Length (A_Value) = Length (In_Object);
when An_Integer_Value =>
if A_Value.Int_Value < Lower_Bound (In_Object) or else
A_Value.Int_Value > Upper_Bound (In_Object) then
return False;
else
return True;
end if;
when A_Float_Value =>
if A_Value.Flt_Value < Lower_Bound (In_Object) or else
A_Value.Flt_Value > Upper_Bound (In_Object) then
return False;
else
return True;
end if;
when Other_Value =>
return True;
end case;
else
raise Bad_Kind;
end if;
end Fits;
function Image (F : Float) return String is
Local : String (1 .. 100);
begin
Float_Conversion.Put (Local, F);
return String_Utilities.Strip (Local);
end Image;
function Problem_Description
(A_Value : Value; In_Object : Object) return String is
begin
if Match (A_Value, In_Object) then
case A_Value.Kind is
when A_String_Value | An_Array_Aggregate =>
if Length (A_Value) /= Length (In_Object) then
return "The size of the value " &
Integer'Image (Length (A_Value)) &
" does not match the object's length " &
Integer'Image (Length (In_Object));
else
return "NO PROBLEM";
end if;
when An_Integer_Value =>
if A_Value.Int_Value > Upper_Bound (In_Object) then
return "The value " & Long_Integer'Image (A_Value.Int_Value) &
" exceeds the upper bound " &
Long_Integer'Image (Upper_Bound (In_Object));
elsif A_Value.Int_Value < Lower_Bound (In_Object) then
return "The value " &
Long_Integer'Image (A_Value.Int_Value) &
" is less than the lower bound " &
Long_Integer'Image (Lower_Bound (In_Object));
else
return "NO PROBLEM";
end if;
when A_Float_Value =>
if A_Value.Flt_Value < Lower_Bound (In_Object) then
return "The value " & Image (A_Value.Flt_Value) &
" is less than the lower bound " &
Image (Lower_Bound (In_Object));
elsif A_Value.Flt_Value > Upper_Bound (In_Object) then
return "The value " & Image (A_Value.Flt_Value) &
" exceeds the upper bound " &
Image (Upper_Bound (In_Object));
else
return "NO PROBLEM";
end if;
when Other_Value =>
return "";
end case;
else
return "BAD MATCH";
end if;
end Problem_Description;
function Lower_Bound (Of_Integer_Or_String_Object : Object)
return Long_Integer is
begin
case Of_Integer_Or_String_Object.Kind is
when A_String_Object | An_Integer_Object | An_Array_Object =>
return Of_Integer_Or_String_Object.Lower_Bound;
when others =>
raise Bad_Kind;
end case;
end Lower_Bound;
function Upper_Bound (Of_Integer_Or_String_Object : Object)
return Long_Integer is
begin
case Of_Integer_Or_String_Object.Kind is
when A_String_Object | An_Integer_Object | An_Array_Object =>
return Of_Integer_Or_String_Object.Upper_Bound;
when others =>
raise Bad_Kind;
end case;
end Upper_Bound;
function Lower_Bound (Of_Float_Object : Object) return Float is
begin
case Of_Float_Object.Kind is
when A_Float_Object =>
return Of_Float_Object.Lower_Flt_Bound;
when others =>
raise Bad_Kind;
end case;
end Lower_Bound;
function Upper_Bound (Of_Float_Object : Object) return Float is
begin
case Of_Float_Object.Kind is
when A_Float_Object =>
return Of_Float_Object.Upper_Flt_Bound;
when others =>
raise Bad_Kind;
end case;
end Upper_Bound;
function Length (Of_String_Or_Array_Object : Object) return Natural is
begin
case Of_String_Or_Array_Object.Kind is
when A_String_Object | An_Array_Object =>
return Of_String_Or_Array_Object.Size;
when others =>
raise Bad_Kind;
end case;
end Length;
function Length (Of_String_Or_Array_Aggregate : Value) return Natural is
begin
case Of_String_Or_Array_Aggregate.Kind is
when A_String_Value | An_Array_Aggregate =>
return Of_String_Or_Array_Aggregate.Size;
when others =>
raise Bad_Kind;
end case;
end Length;
function Static_Value (Of_Integer_Value_Or_Constant : Value)
return Long_Integer is
begin
case Of_Integer_Value_Or_Constant.Kind is
when An_Integer_Value =>
return Of_Integer_Value_Or_Constant.Int_Value;
when others =>
raise Bad_Kind;
end case;
end Static_Value;
function Static_Value (Of_Float_Value_Or_Constant : Value) return Float is
begin
case Of_Float_Value_Or_Constant.Kind is
when A_Float_Value =>
return Of_Float_Value_Or_Constant.Flt_Value;
when others =>
raise Bad_Kind;
end case;
end Static_Value;
end Constraint_Utilities;
nblk1=1f
nid=0
hdr6=3e
[0x00] rec0=20 rec1=00 rec2=01 rec3=034
[0x01] rec0=1a rec1=00 rec2=1e rec3=00a
[0x02] rec0=00 rec1=00 rec2=02 rec3=01c
[0x03] rec0=1a rec1=00 rec2=03 rec3=032
[0x04] rec0=01 rec1=00 rec2=1f rec3=006
[0x05] rec0=1a rec1=00 rec2=04 rec3=00c
[0x06] rec0=01 rec1=00 rec2=1d rec3=02a
[0x07] rec0=15 rec1=00 rec2=05 rec3=01e
[0x08] rec0=19 rec1=00 rec2=06 rec3=020
[0x09] rec0=13 rec1=00 rec2=07 rec3=070
[0x0a] rec0=00 rec1=00 rec2=1c rec3=002
[0x0b] rec0=1b rec1=00 rec2=08 rec3=038
[0x0c] rec0=00 rec1=00 rec2=1b rec3=01e
[0x0d] rec0=13 rec1=00 rec2=09 rec3=004
[0x0e] rec0=13 rec1=00 rec2=0a rec3=008
[0x0f] rec0=13 rec1=00 rec2=0b rec3=026
[0x10] rec0=13 rec1=00 rec2=0c rec3=000
[0x11] rec0=1e rec1=00 rec2=0d rec3=02c
[0x12] rec0=1a rec1=00 rec2=0e rec3=046
[0x13] rec0=01 rec1=00 rec2=1a rec3=004
[0x14] rec0=12 rec1=00 rec2=0f rec3=078
[0x15] rec0=15 rec1=00 rec2=10 rec3=008
[0x16] rec0=1d rec1=00 rec2=11 rec3=048
[0x17] rec0=22 rec1=00 rec2=12 rec3=03c
[0x18] rec0=1a rec1=00 rec2=13 rec3=038
[0x19] rec0=18 rec1=00 rec2=14 rec3=002
[0x1a] rec0=11 rec1=00 rec2=15 rec3=000
[0x1b] rec0=1c rec1=00 rec2=16 rec3=020
[0x1c] rec0=1e rec1=00 rec2=17 rec3=008
[0x1d] rec0=1d rec1=00 rec2=18 rec3=048
[0x1e] rec0=14 rec1=00 rec2=19 rec3=000
tail 0x217002460815c65cf283f 0x42a00088462061e03