|
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: 26624 (0x6800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Bounds_Utilities, seg_004618
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Io;
with Lrm_Utilities;
with Sizing_Parameters;
use Sizing_Parameters;
with Declarations;
package body Bounds_Utilities is
package Decls renames Declarations;
package Exprs renames Names_And_Expressions;
package Ada renames Ada_Program;
package Types renames Type_Information;
function Static_Value
(Expression : Ada_Program.Expression) return Long_Integer
renames Lrm_Utilities.Static_Value;
function Static_Value (Expression : Ada_Program.Expression) return Float
renames Lrm_Utilities.Static_Value;
function "=" (A, B : Types.Range_Kinds) return Boolean renames Types."=";
function Actual_Delta
(Of_Fixed_Point_Constraint : Types.Fixed_Type_Definition)
return Float is
Fixed_Accuracy_Definition : Types.Expression;
Specified_Delta : Float;
Integer_Floor : Long_Integer;
One : constant Float := 1.00_00_00;
Integer_Size : Natural;
begin
Fixed_Accuracy_Definition :=
Types.Delta_Accuracy_Definition (Of_Fixed_Point_Constraint);
Specified_Delta := Names_And_Expressions.Static_Value
(Fixed_Accuracy_Definition);
if Specified_Delta < One then
Integer_Floor := Long_Integer ((1.0 / Specified_Delta) - 0.5);
Integer_Size := Natural (Integer_Type_Size (0, Integer_Floor - 1));
return 1.0 / Float (2 ** Integer_Size);
else
Integer_Floor := Long_Integer (Specified_Delta - 0.5);
Integer_Size := Natural (Integer_Type_Size (0, Integer_Floor - 1));
return Float (2 ** Integer_Size);
end if;
end Actual_Delta;
--
-- function Enumeration_Range_Constraint_Image
-- (Constraint : Types.Type_Constraint) return String is
-- Lower, Upper : Types.Expression;
-- Lbound, Ubound : Long_Integer;
-- Static : Boolean;
-- begin
-- Enumeration_Range_Constraint_Bounds
-- (Constraint, Lbound, Ubound, Static);
-- if Static then
-- return Image (Lbound) & " .. " & Image (Ubound);
-- else
-- Types.Bounds (Constraint, Lower, Upper);
-- if Ada.Is_Nil (Lower) then
-- return Not_Static;
-- else
-- return Ada.Image (Lower) & " .. " & Ada.Image (Upper);
-- end if;
-- end if;
-- end Enumeration_Range_Constraint_Image;
--
-- function Integer_Range_Constraint_Image
-- (Constraint : Types.Type_Constraint) return String is
-- Lower, Upper : Types.Expression;
-- Lbound, Ubound : Long_Integer;
-- Static : Boolean;
-- begin
-- Integer_Range_Constraint_Bounds (Constraint, Lbound, Ubound, Static);
-- if Static then
-- return Image (Lbound) & " .. " & Image (Ubound);
-- else
-- if Ada.Is_Nil (Lower) then
-- return Not_Static;
-- else
-- Types.Bounds (Constraint, Lower, Upper);
-- return Ada.Image (Lower) & " .. " & Ada.Image (Upper);
-- end if;
--
-- end if;
-- end Integer_Range_Constraint_Image;
--
-- function Float_Range_Constraint_Image
-- (Constraint : Types.Type_Constraint) return String is
-- Lower, Upper : Types.Expression;
-- Lbound, Ubound : Float;
-- Static : Boolean;
-- begin
-- case Types.Constraint_Kind (Constraint) is
-- when Types.A_Simple_Range =>
-- Float_Range_Constraint_Bounds
-- (Constraint, Lbound, Ubound, Static);
-- if Static then
-- return Float_Image (Lbound) & " .. " & Float_Image (Ubound);
-- else
-- Types.Bounds (Constraint, Lower, Upper);
-- if Ada.Is_Nil (Lower) then
-- return Not_Static;
-- else
-- return Ada.Image (Lower) & " .. " & Ada.Image (Upper);
-- end if;
--
-- end if;
--
-- when Types.A_Range_Attribute =>
-- return Ada.Image (Constraint);
--
-- when others =>
-- return Not_Static;
-- end case;
-- exception
-- when others =>
-- return Ada.Image (Simple_Range (Constraint));
-- end Float_Range_Constraint_Image;
--
-- function Fixed_Range_Constraint_Image
-- (Constraint : Types.Type_Constraint) return String is
-- Lower, Upper : Types.Expression;
-- Static : Boolean;
-- begin
-- case Types.Constraint_Kind (Constraint) is
-- when Types.A_Simple_Range =>
-- Types.Bounds (Constraint, Lower, Upper);
-- if Ada.Is_Nil (Lower) then
-- return Not_Static;
-- else
-- return Ada.Image (Lower) & " .. " & Ada.Image (Upper);
-- end if;
--
-- when Types.A_Range_Attribute =>
-- return Ada.Image (Constraint);
--
-- when others =>
-- return Not_Static;
-- end case;
-- exception
-- when others =>
-- return Ada.Image (Simple_Range (Constraint));
-- end Fixed_Range_Constraint_Image;
------
procedure Find_Range (The_Range : Type_Information.Discrete_Range;
Lbound, Ubound : in out Long_Integer;
Static : out Boolean;
Non_Static_Lbound, Non_Static_Ubound : out
Names_And_Expressions.Expression) is
Type_Mark_Spec : Types.Type_Definition;
Constraint : Types.Type_Constraint;
Lower_Expression, Upper_Expression : Types.Expression;
procedure Process_Expressions is
begin
case Types.Range_Kind (Constraint) is
-- **** WORK AROUND FOR BUG FIX ****
when Types.A_Range_Attribute =>
Static := False;
return;
when others =>
Types.Bounds (Constraint, Lower_Expression,
Upper_Expression);
end case;
Lbound := Static_Value (Lower_Expression);
Ubound := Static_Value (Upper_Expression);
Static := True;
exception
when Lrm_Utilities.Not_Static =>
Static := False;
Non_Static_Lbound := Lower_Expression;
Non_Static_Ubound := Upper_Expression;
end Process_Expressions;
begin
Static := True;
if Types.Range_Kind (The_Range) = Types.A_Subtype_Indication then
Constraint := Types.Constraint (The_Range);
if Ada.Is_Nil (Constraint) then
-- The constraint is a subtype indication with no bounds,
-- so we'll use the bounds of the subtype indication ...
Type_Mark_Spec :=
Decls.Type_Specification
(Ada.Definition (Types.Type_Mark (The_Range)));
loop
case Types.Kind (Type_Mark_Spec) is
when Types.A_Subtype_Indication =>
-- must have a constraint now ...
Constraint := Types.Constraint (Type_Mark_Spec);
Process_Expressions;
exit;
when Types.An_Enumeration_Type_Definition =>
Enumeration_Range (Type_Mark_Spec, Lbound, Ubound);
Static := Ubound >= Lbound;
exit;
when Types.An_Integer_Type_Definition =>
Constraint := Types.Integer_Constraint
(Type_Mark_Spec);
Process_Expressions;
exit;
when Types.A_Derived_Type_Definition =>
-- look past any non-constraining subtyping ...
Type_Mark_Spec :=
Types.Derived_From (Type_Mark_Spec);
when others =>
raise Program_Error; -- can't happen.
end case;
end loop;
else
Constraint := Types.Constraint (The_Range);
Process_Expressions;
end if;
else
Constraint := The_Range;
Process_Expressions;
end if;
end Find_Range;
--
procedure Enumeration_Range (Enum_Type_Def : Ada_Program.Type_Definition;
Lbound, Ubound : in out Long_Integer) is
Enum_Elements : Ada.Element_Iterator;
begin
Enum_Elements := Types.Enumeration_Literals (Enum_Type_Def);
Lbound := 0;
Ubound := Lbound - 1;
while not Ada.Done (Enum_Elements) loop
Ubound := Ubound + 1;
Ada.Next (Enum_Elements);
end loop;
end Enumeration_Range;
procedure Integer_Range_Constraint_Bounds
(Constraint : Type_Information.Type_Constraint;
Lbound, Ubound : in out Long_Integer;
Static : out Boolean) is
Lower, Upper : Types.Expression;
begin
if Ada.Is_Nil (Constraint) then
Static := False;
Lbound := 0;
Ubound := 0;
return;
end if;
case Types.Constraint_Kind (Constraint) is
when Types.A_Simple_Range =>
Types.Bounds (Constraint, Lower, Upper);
Lbound := Static_Value (Lower);
Ubound := Static_Value (Upper);
Static := True;
when others =>
Lbound := 0;
Ubound := 0;
Static := False;
end case;
exception
when Lrm_Utilities.Not_Static =>
Lbound := 0;
Ubound := 0;
Static := False;
end Integer_Range_Constraint_Bounds;
procedure Enumeration_Range_Constraint_Bounds
(Constraint : Type_Information.Type_Constraint;
Lbound, Ubound : in out Long_Integer;
Static : out Boolean) is
Lower, Upper : Types.Expression;
begin
case Types.Constraint_Kind (Constraint) is
when Types.A_Simple_Range =>
Types.Bounds (Constraint, Lower, Upper);
Lbound := Static_Value (Lower);
Ubound := Static_Value (Upper);
Static := True;
when others =>
Lbound := 0;
Ubound := 0;
Static := False;
end case;
exception
when Lrm_Utilities.Not_Static =>
Lbound := 0;
Ubound := 0;
Static := False;
end Enumeration_Range_Constraint_Bounds;
procedure Determine_Model_Number_Range
(Lower_Bound, Upper_Bound, Delta_Accuracy : Float;
Lower_Model, Upper_Model : out Long_Integer) is
begin
-- Check LRM and make reference to appropriate section.
Lower_Model := Long_Integer ((Lower_Bound / Delta_Accuracy) - 0.5);
Upper_Model := Long_Integer ((Upper_Bound / Delta_Accuracy) - 0.5);
end Determine_Model_Number_Range;
procedure Fixed_Range_Constraint_Bounds
(Fixed_Type_Definition :
Type_Information.Fixed_Type_Definition;
Range_Constraint : Type_Information.Type_Constraint;
Lower_Model, Upper_Model : in out Long_Integer;
Static : out Boolean) is
Lower, Upper : Types.Expression;
Lbound, Ubound : Float;
begin
if Ada.Is_Nil (Range_Constraint) or else
Ada.Is_Nil (Fixed_Type_Definition) then
Static := False;
Lower_Model := 0;
Upper_Model := 0;
return;
end if;
case Types.Range_Kind (Range_Constraint) is
when Types.A_Simple_Range =>
Types.Bounds (Range_Constraint, Lower, Upper);
Ubound := Static_Value (Upper);
Lbound := Static_Value (Lower);
Determine_Model_Number_Range
(Lbound, Ubound, Actual_Delta (Fixed_Type_Definition),
Lower_Model, Upper_Model);
Static := True;
when others =>
Lower_Model := 0;
Upper_Model := 0;
Static := False;
end case;
exception
when Lrm_Utilities.Not_Static =>
Lower_Model := 0;
Upper_Model := 0;
Static := False;
end Fixed_Range_Constraint_Bounds;
procedure Float_Range_Constraint_Bounds
(Constraint : Type_Information.Type_Constraint;
Lbound, Ubound : in out Float;
Static : out Boolean) is
Lower, Upper : Types.Expression;
begin
if Ada.Is_Nil (Constraint) then
Lbound := Float'First;
Ubound := Float'Last;
Static := True; return;
end if;
case Types.Constraint_Kind (Constraint) is
when Types.A_Simple_Range =>
Types.Bounds (Constraint, Lower, Upper);
Lbound := Static_Value (Lower);
Ubound := Static_Value (Upper);
Static := True;
when others =>
Lbound := 0.0;
Ubound := 0.0;
Static := False;
end case;
exception
when Lrm_Utilities.Not_Static =>
Lbound := 0.0;
Ubound := 0.0;
Static := False;
end Float_Range_Constraint_Bounds;
---
-- function Range_Image (Ref_Id : Ada.Identifier_Reference := Ada.Nil_Element;
-- Original : Types.Type_Definition;
-- Constraint : Types.Type_Constraint;
-- Analyze_Private_Types : Boolean) return String is
-- Ground : Types.Type_Definition := Types.Ground_Type (Original);
-- Constraints : Ada.Element_Iterator;
-- Range_Constraint, Garbage : Types.Type_Constraint;
-- Lbound, Ubound : Long_Integer;
-- begin
-- case Types.Kind (Ground) is
-- when Types.An_Enumeration_Type_Definition =>
-- return Enumeration_Range_Constraint_Image (Constraint);
--
-- when Types.An_Integer_Type_Definition =>
-- return Integer_Range_Constraint_Image (Constraint);
--
-- when Types.A_Fixed_Type_Definition =>
-- Find_Fixed_Constraints (Ref_Id => Ref_Id,
-- Root => Original,
-- First => Constraint,
-- Range_Constraint => Range_Constraint,
-- Delta_Constraint => Garbage);
-- return Fixed_Range_Constraint_Image (Range_Constraint);
--
-- when Types.A_Float_Type_Definition =>
-- Find_Float_Constraints (Ref_Id => Ref_Id,
-- Root => Original,
-- First => Constraint,
-- Range_Constraint => Range_Constraint,
-- Digits_Constraint => Garbage);
-- return Float_Range_Constraint_Image (Range_Constraint);
--
-- when Types.An_Array_Type_Definition =>
-- return Index_Constraints_Image
-- (Types.Discrete_Ranges (Constraint));
--
-- when others =>
-- -- Can't happen ...
-- return Internal_Error;
-- end case;
-- end Range_Image;
procedure Get_Constraints (Discrete_Type_Def : Ada_Program.Type_Definition;
Lower_Pos, Upper_Pos : in out Long_Integer;
Static : out Boolean) is
Constrained_Subtype : Ada.Element;
Lower, Upper : Ada.Element;
Ground_Type_Def : Ada.Element := Types.Ground_Type (Discrete_Type_Def);
begin
Constrained_Subtype := Types.Last_Constraint (Discrete_Type_Def);
case Types.Kind (Constrained_Subtype) is
when Types.A_Subtype_Indication =>
case Types.Kind (Ground_Type_Def) is
when Types.An_Enumeration_Type_Definition =>
Bounds_Utilities.Enumeration_Range_Constraint_Bounds
(Types.Constraint (Constrained_Subtype),
Lower_Pos, Upper_Pos, Static);
when Types.An_Integer_Type_Definition =>
Bounds_Utilities.Integer_Range_Constraint_Bounds
(Types.Constraint (Constrained_Subtype),
Lower_Pos, Upper_Pos, Static);
when others =>
raise Program_Error;
end case;
when Types.A_Derived_Type_Definition =>
Get_Constraints (Types.Derived_From (Discrete_Type_Def),
Lower_Pos, Upper_Pos, Static);
when Types.An_Enumeration_Type_Definition =>
Bounds_Utilities.Enumeration_Range
(Ground_Type_Def, Lower_Pos, Upper_Pos);
Static := True;
when Types.An_Integer_Type_Definition =>
Bounds_Utilities.Find_Range
(Types.Integer_Constraint (Constrained_Subtype),
Lower_Pos, Upper_Pos, Static, Lower, Upper);
when others =>
raise Ada.Inappropriate_Program_Element;
end case;
end Get_Constraints;
end Bounds_Utilities;
nblk1=19
nid=0
hdr6=32
[0x00] rec0=20 rec1=00 rec2=01 rec3=006
[0x01] rec0=00 rec1=00 rec2=19 rec3=004
[0x02] rec0=18 rec1=00 rec2=02 rec3=048
[0x03] rec0=00 rec1=00 rec2=18 rec3=004
[0x04] rec0=19 rec1=00 rec2=03 rec3=04e
[0x05] rec0=19 rec1=00 rec2=04 rec3=012
[0x06] rec0=1a rec1=00 rec2=05 rec3=042
[0x07] rec0=19 rec1=00 rec2=06 rec3=010
[0x08] rec0=1a rec1=00 rec2=07 rec3=024
[0x09] rec0=00 rec1=00 rec2=17 rec3=016
[0x0a] rec0=16 rec1=00 rec2=08 rec3=046
[0x0b] rec0=17 rec1=00 rec2=09 rec3=00c
[0x0c] rec0=1c rec1=00 rec2=0a rec3=016
[0x0d] rec0=00 rec1=00 rec2=16 rec3=01c
[0x0e] rec0=1f rec1=00 rec2=0b rec3=048
[0x0f] rec0=1a rec1=00 rec2=0c rec3=03c
[0x10] rec0=19 rec1=00 rec2=0d rec3=044
[0x11] rec0=00 rec1=00 rec2=15 rec3=00e
[0x12] rec0=1d rec1=00 rec2=0e rec3=002
[0x13] rec0=00 rec1=00 rec2=14 rec3=014
[0x14] rec0=1a rec1=00 rec2=0f rec3=05c
[0x15] rec0=13 rec1=00 rec2=10 rec3=006
[0x16] rec0=16 rec1=00 rec2=11 rec3=004
[0x17] rec0=11 rec1=00 rec2=12 rec3=00e
[0x18] rec0=18 rec1=00 rec2=13 rec3=001
tail 0x217002454815c65bdb997 0x42a00088462061e03