|
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: 53248 (0xd000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package Semantic_Characteristics, pragma Module_Name 4 4143, pragma Segmented_Heap Address_Clause_Data, pragma Segmented_Heap Argument, pragma Segmented_Heap Argument_Array_Ptr, pragma Segmented_Heap Attribute, pragma Segmented_Heap Designator, pragma Segmented_Heap Expression, pragma Segmented_Heap Fixed_Type_Array_Ptr, pragma Segmented_Heap Fixed_Type_Descriptor, pragma Segmented_Heap Float_Type_Array_Ptr, pragma Segmented_Heap Float_Type_Descriptor, pragma Segmented_Heap Identifier_Array_Ptr, pragma Segmented_Heap Integer_Type_Array_Ptr, pragma Segmented_Heap Integer_Type_Descriptor, pragma Segmented_Heap Item, pragma Segmented_Heap Miscellaneous_Name_Set, pragma Segmented_Heap Object, pragma Segmented_Heap Object_Set, pragma Segmented_Heap Pragma_Array_Ptr, pragma Segmented_Heap Prefix, pragma Segmented_Heap Range_Constraint, pragma Segmented_Heap Range_Data, pragma Segmented_Heap Result, pragma Segmented_Heap Storage_Size_Data, pragma Segmented_Heap Target_Pragma, pragma Segmented_Heap Target_Pragma_Array_Ptr, pragma Segmented_Heap Type_Name_Array_Ptr, pragma Segmented_Heap Type_Set, pragma Segmented_Heap Universal_Real, seg_01b238
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Simple_Status;
with Universal;
pragma Private_Eyes_Only;
with Eniversal;
package Semantic_Characteristics is
subtype Target_Id is Natural range 0 .. 256;
Invalid_Access : exception;
-- Get on something never built
-- Raised for access of nonexistant variant field
Target_Is_Registered : exception;
Target_Not_Initialized : exception;
package Text is
type Item is private;
function Build (S : String; For_Target : String) return Item;
function Get (T : Item) return String;
type List is array (Positive range <>) of Item;
private
type Item is access String;
pragma Segmented_Heap (Item);
end Text;
----------------------------------------------------------------------
-- Type checking
package Checking is
type Structural_Type_Kind is
(Access_Type, Array_Type, Enumeration_Type, Integer_Type,
Fixed_Point_Type, Floating_Point_Type, Formal_Discrete_Type,
Formal_Fixed_Type, Formal_Float_Type, Formal_Integer_Type,
Record_Type, Task_Type, Universal_Integer_Type,
Universal_Fixed_Type, Universal_Real_Type);
type Type_Restriction_Kind is
(No_Subtypes, No_Private_Types,
No_Limited_Private_Types, No_Derived_Types);
-- Future ideas: Constraints, discrims, dif decl parts,
-- ambiguous names, etc.
type Structural_Type_Array is array (Structural_Type_Kind) of Boolean;
All_Structural_Types :
constant Structural_Type_Array := (others => True);
No_Structural_Types : constant Structural_Type_Array :=
(others => False);
type Type_Restriction_Array is array (Type_Restriction_Kind) of Boolean;
All_Type_Restrictions :
constant Type_Restriction_Array := (others => True);
No_Type_Restrictions :
constant Type_Restriction_Array := (others => False);
subtype Type_Name is String;
-- For universal_integer use "universal_integer", not
-- "Standard.universal_integer" or anything else.
subtype Type_Name_Array is Text.List;
No_Type_Names : Type_Name_Array (1 .. 0);
subtype Pragma_Array is Text.List;
No_Pragmas : Pragma_Array (1 .. 0);
----------
type Type_Set is private;
-- A type_set describes the valid type names for a given
-- argument.
-- eg. In the statement 'pragma foo (<bar>);', where <bar>
-- names a type, a type_set would be used in the description of
-- pragma 'foo' to describe what kind of type <bar> can be.
-- Type_sets are NOT used to represent the types of expressions.
-- Type sets consist of the following.
--
-- Enforced_Type_Restrictions:
-- Miscellaneous restrictions about non-structural
-- aspects of the type.
--
-- Valid_Structural_Types:
-- Which general structural categories are allowed.
-- (Record, array, Access, etc).
-- This is ignored if the type under consideration matches
-- one of the 'Valid_Textual_Types'.
--
-- Valid_Textual_Types:
-- A list of the names of SPECIFIC types that are allowed for
-- an argument. eg "Integer", "System.Address",
-- "Text_Io.Count". Only types from predefined units are
-- allowed. Visibility to package Standard is implicit so
-- it is not necessary to say "Standard.Character" as
-- "Character" will suffice.
-- Note that Enforced_type_restrictions must hold when the type
-- under consideration is derived in some manner from one
-- of the Valid_Textual_Types, but do not apply to the textual
-- type itself.
-- eg. if the 'no_derived_types' restriction is present,
-- and "System.Address" is a valid_textual_type, then
-- type T is new System.Address;
-- pragma Foo (T);
-- is rejected, but
-- pragma Foo (System.Address);
-- and
-- subtype T is System.Address;
-- pragma Foo (T);
-- are not, REGARDLESS of whether System.Address is
-- a derived type.
--
-- Required_Pragmas and Prohibited_Pragmas are pragmas that must or
-- must not be applied to the type under consideration to make it
-- legal. Again, this check is not made on any of the
-- 'Valid_Textual_Types' or its ancestors.
function Null_Type_Set return Type_Set;
-- A null type_set means no types are allowed
function Is_Null (The_Type_Set : Type_Set) return Boolean;
function Build (Enforced_Type_Restrictions : Type_Restriction_Array;
Valid_Structural_Types : Structural_Type_Array;
Valid_Textual_Types : Type_Name_Array :=
Checking.No_Type_Names;
Required_Pragmas : Pragma_Array := Checking.No_Pragmas;
Prohibited_Pragmas : Pragma_Array :=
Checking.No_Pragmas;
For_Target : String) return Type_Set;
function Get_Enforced_Type_Restrictions
(The_Type_Set : Type_Set) return Type_Restriction_Array;
function Get_Valid_Structural_Types
(The_Type_Set : Type_Set) return Structural_Type_Array;
function Get_Valid_Textual_Types
(The_Type_Set : Type_Set) return Type_Name_Array;
function Get_Required_Pragmas
(The_Type_Set : Type_Set) return Pragma_Array;
function Get_Prohibited_Pragmas
(The_Type_Set : Type_Set) return Pragma_Array;
----------------------------------------------------------------------
-- expressions
type Expression_Form is (Integer_Form, Real_Form, Other_Form);
----------------------------------------------------------------------
-- expression description
----------
type Range_Data is private;
-- Range_data is for scalar expressions that must be static and must
-- lie within known bounds.
-- Expressions that can be non-static or are not scalar base types
-- should use build_no_range.
--
function Build_Integer_Range
(Lo, Hi : Universal.Integer; For_Target : String)
return Range_Data;
function Build_Real_Range
(Lo, Hi : Universal.Float; For_Target : String)
return Range_Data;
function Build_No_Range (For_Target : String) return Range_Data;
function Get_Expression_Form
(The_Range_Data : Range_Data) return Expression_Form;
function Get_Integer_Lo (The_Range_Data : Range_Data)
return Universal.Integer;
function Get_Integer_Hi (The_Range_Data : Range_Data)
return Universal.Integer;
function Get_Real_Lo (The_Range_Data : Range_Data)
return Universal.Float;
function Get_Real_Hi (The_Range_Data : Range_Data)
return Universal.Float;
----------
type Range_Constraint is private;
function Is_Null
(The_Range_Constraint : Range_Constraint) return Boolean;
function Build_With_Static_Range
(The_Range_Data : Range_Data; For_Target : String)
return Range_Constraint;
function Null_Constraint (For_Target : String) return Range_Constraint;
-- A null range_constraint is just a range built with build_no_range.
-- Use for non-scalar or non-static expressions.
function Get_Must_Be_Static
(The_Range_Constraint : Range_Constraint) return Boolean;
function Get_Range_Data
(The_Range_Constraint : Range_Constraint) return Range_Data;
----------
type Expression is private;
-- An abstract expression represents an set of valid ada expressions.
-- The components consist of the type of the expression and a
-- constraint if any. If expression is static and violates the
-- bounds of the expression type itself, a warning will be produced
-- regardless of the presence or absence of the 'constraint'
-- component.
-- A null expression does not mean no expressions are allowed, it
-- means that no information is available about the set of allowed
-- expressions and thus ALL expressions are allowed.
function Null_Expression return Expression;
function Is_Null (The_Expression : Expression) return Boolean;
function Build (Expression_Type : Type_Name;
Constraint : Range_Constraint;
For_Target : String) return Expression;
function Get_Expression_Type
(The_Expression : Expression) return Type_Name;
function Get_Constraint (The_Expression : Expression)
return Range_Constraint;
----------------------------------------------------------------------
-- Identifiers
subtype Identifier_Array is Text.List;
No_Identifiers : Identifier_Array (1 .. 0);
All_Special_Identifiers : Identifier_Array (1 .. -1);
----------------------------------------------------------------------
-- Object checking
type Object_Kind is (Constant_Kind, Discriminant, In_Out_Parameter,
In_Parameter, Iteration_Variable,
Named_Number, Out_Parameter, Variable);
type Miscellaneous_Name_Kind is
(Function_Kind, Package_Kind, Procedure_Kind, Task_Kind,
Entry_Kind, Exception_Kind, Enumeration_Literal_Kind,
Record_Component_Kind, Generic_Package_Kind, Generic_Procedure_Kind,
Generic_Function_Kind, Generic_Formal_Procedure,
Generic_Formal_Function, Label_Kind, Named_Statement_Kind);
type Object_Kind_Array is array (Object_Kind) of Boolean;
No_Object_Kinds : constant Object_Kind_Array := (others => False);
All_Object_Kinds : constant Object_Kind_Array := (others => True);
type Miscellaneous_Name_Kind_Array is
array (Miscellaneous_Name_Kind) of Boolean;
No_Miscellaneous_Name_Kinds :
constant Miscellaneous_Name_Kind_Array := (others => False);
All_Miscellaneous_Name_Kinds :
constant Miscellaneous_Name_Kind_Array := (others => True);
----------
type Object_Set is private;
-- An object_set describes the allowed ada object names for a given
-- argument. Object_sets are NOT used to describe expressions, even
-- though objects can be expressions.
-- The components of an object_set are the following:
-- Valid_Kinds:
-- What forms of objects are allowed,
-- (Constants, Named_Numbers, out parameters, etc.)
-- Allowed_Types
-- Which types can the object have.
-- Required and Prohibited Pragmas
-- Which pragmas must or must not be applied to the object.
--
function Null_Object_Set return Object_Set;
-- A null object_set means no objects are allowed
function Is_Null (The_Object_Set : Object_Set) return Boolean;
function Build (Valid_Kinds : Object_Kind_Array;
Allowed_Types : Type_Set;
Required_Pragmas : Pragma_Array := Checking.No_Pragmas;
Prohibited_Pragmas : Pragma_Array :=
Checking.No_Pragmas;
For_Target : String) return Object_Set;
function Get_Valid_Kinds (The_Object_Set : Object_Set)
return Object_Kind_Array;
function Get_Allowed_Types
(The_Object_Set : Object_Set) return Type_Set;
function Get_Required_Pragmas
(The_Object_Set : Object_Set) return Pragma_Array;
function Get_Prohibited_Pragmas
(The_Object_Set : Object_Set) return Pragma_Array;
----------
type Miscellaneous_Name_Set is private;
-- Miscellaneous_Name_Sets are used to describe ada names other than
-- types or objects. (Such as functions, exceptions, and generics).
-- Note that since enumeration_literals, functions, procedures,
-- and entries can be overloaded, some miscellaneous names are
-- ambiguous. The ambiguity_allowed component of a miscellaneous_
-- name_set denotes whether an ambiguous name can be used for the
-- given argument.
function Null_Miscellaneous_Name_Set return Miscellaneous_Name_Set;
-- A null miscellaneous_name_set means no miscellaneous names are
-- allowed.
function Is_Null (The_Miscellaneous_Name_Set : Miscellaneous_Name_Set)
return Boolean;
function Build (Valid_Kinds : Miscellaneous_Name_Kind_Array;
Ambiguity_Allowed : Boolean := True;
Required_Pragmas : Pragma_Array := Checking.No_Pragmas;
Prohibited_Pragmas : Pragma_Array :=
Checking.No_Pragmas;
For_Target : String) return Miscellaneous_Name_Set;
function Ambiguity_Allowed
(The_Miscellaneous_Name_Set : Miscellaneous_Name_Set)
return Boolean;
function Get_Valid_Kinds
(The_Miscellaneous_Name_Set : Miscellaneous_Name_Set)
return Miscellaneous_Name_Kind_Array;
function Get_Required_Pragmas
(The_Miscellaneous_Name_Set : Miscellaneous_Name_Set)
return Pragma_Array;
function Get_Prohibited_Pragmas
(The_Miscellaneous_Name_Set : Miscellaneous_Name_Set)
return Pragma_Array;
private
type Pragma_Array_Ptr is access Pragma_Array;
pragma Segmented_Heap (Pragma_Array_Ptr);
type Type_Name_Array_Ptr is access Type_Name_Array;
pragma Segmented_Heap (Type_Name_Array_Ptr);
type Range_Data_Record (Form : Expression_Form :=
Checking.Other_Form) is
record
case Form is
when Integer_Form =>
Integer_Lo : Universal.Integer;
Integer_Hi : Universal.Integer;
when Real_Form =>
Real_Lo : Universal.Float;
Real_Hi : Universal.Float;
when Other_Form =>
null;
end case;
end record;
type Range_Data is access Range_Data_Record;
pragma Segmented_Heap (Range_Data);
type Range_Constraint_Record
(Must_Be_Static : Boolean := False) is
record
case Must_Be_Static is
when True =>
The_Range_Data : Range_Data;
when False =>
null;
end case;
end record;
type Range_Constraint is access Range_Constraint_Record;
pragma Segmented_Heap (Range_Constraint);
type Object_Set_Record is
record
Valid_Kinds : Object_Kind_Array;
Allowed_Types : Type_Set;
Required_Pragmas : Pragma_Array_Ptr;
Prohibited_Pragmas : Pragma_Array_Ptr;
end record;
type Object_Set is access Object_Set_Record;
pragma Segmented_Heap (Object_Set);
type Miscellaneous_Name_Set_Record is
record
Miscellaneous_Name_Kinds : Miscellaneous_Name_Kind_Array;
Ambiguity_Allowed : Boolean;
Required_Pragmas : Pragma_Array_Ptr;
Prohibited_Pragmas : Pragma_Array_Ptr;
end record;
type Miscellaneous_Name_Set is access Miscellaneous_Name_Set_Record;
pragma Segmented_Heap (Miscellaneous_Name_Set);
type Type_Set_Record is
record
Enforced_Type_Restrictions : Type_Restriction_Array;
Valid_Structural_Types : Structural_Type_Array;
Valid_Textual_Types : Type_Name_Array_Ptr;
Required_Pragmas : Pragma_Array_Ptr;
Prohibited_Pragmas : Pragma_Array_Ptr;
end record;
type Type_Set is access Type_Set_Record;
pragma Segmented_Heap (Type_Set);
type Expression_Record is
record
Expression_Type : Text.Item;
Constraint : Range_Constraint;
end record;
type Expression is access Expression_Record;
pragma Segmented_Heap (Expression);
end Checking;
----------------------------------------------------------------------
package Predefined_Environment_Characteristics is
----------
type Universal_Real is private;
type Integer_Type_Descriptor is private;
function Is_Null (The_Integer_Type_Descriptor : Integer_Type_Descriptor)
return Boolean;
function Build (Name : String;
Size : Natural;
Lo_Bound : Universal.Integer;
Hi_Bound : Universal.Integer;
For_Target : String) return Integer_Type_Descriptor;
-- Size is measured in bits.
function Get_Name (The_Integer : Integer_Type_Descriptor) return String;
function Get_Size
(The_Integer : Integer_Type_Descriptor) return Natural;
function Get_Lo_Bound (The_Integer : Integer_Type_Descriptor)
return Universal.Integer;
function Get_Hi_Bound (The_Integer : Integer_Type_Descriptor)
return Universal.Integer;
type Integer_Type_Array is
array (Positive range <>) of Integer_Type_Descriptor;
----------
type Float_Type_Descriptor is private;
function Is_Null (The_Float_Type_Descriptor : Float_Type_Descriptor)
return Boolean;
function Build (Name : String;
Digitz : Positive;
Size : Positive;
Lo_Bound : Universal.Real;
Hi_Bound : Universal.Real;
-- The following fields need only be accurately
-- set if the user expects the corresponding
-- LRM attributes for the given float type to be
-- used in expressions that are required to be static.
Safe_Emax : Integer := 0;
Machine_Emax : Integer := 0;
Machine_Emin : Integer := 0;
Machine_Radix : Positive := 1;
Machine_Mantissa : Positive := 1;
Machine_Rounds : Boolean := True;
Machine_Overflows : Boolean := True;
For_Target : String) return Float_Type_Descriptor;
-- Size is measured in bits.
function Get_Name (The_Float : Float_Type_Descriptor) return String;
function Get_Digits (The_Float : Float_Type_Descriptor) return Positive;
function Get_Size (The_Float : Float_Type_Descriptor) return Positive;
function Get_Lo_Bound (The_Float : Float_Type_Descriptor)
return Universal.Real;
function Get_Hi_Bound (The_Float : Float_Type_Descriptor)
return Universal.Real;
function Get_Safe_Emax
(The_Float : Float_Type_Descriptor) return Integer;
function Get_Machine_Emax
(The_Float : Float_Type_Descriptor) return Integer;
function Get_Machine_Emin
(The_Float : Float_Type_Descriptor) return Integer;
function Get_Machine_Radix
(The_Float : Float_Type_Descriptor) return Positive;
function Get_Machine_Mantissa
(The_Float : Float_Type_Descriptor) return Positive;
function Get_Machine_Rounds
(The_Float : Float_Type_Descriptor) return Boolean;
function Get_Machine_Overflows
(The_Float : Float_Type_Descriptor) return Boolean;
type Float_Type_Array is
array (Positive range <>) of Float_Type_Descriptor;
----------
type Fixed_Type_Descriptor is private;
function Is_Null (The_Fixed_Type_Descriptor : Fixed_Type_Descriptor)
return Boolean;
function Build (Name : String;
Size : Positive;
Scale : Integer;
Lo_Bound : Universal.Real;
Hi_Bound : Universal.Real;
For_Target : String) return Fixed_Type_Descriptor;
-- *NOTE* Duration is the only fixed_point type that should appear
-- in package Standard.
-- Size is measured in bits.
-- Scale is outdated and can be set to zero.
function Get_Name (The_Fixed : Fixed_Type_Descriptor) return String;
function Get_Size (The_Fixed : Fixed_Type_Descriptor) return Positive;
function Get_Scale (The_Fixed : Fixed_Type_Descriptor) return Integer;
function Get_Lo_Bound (The_Fixed : Fixed_Type_Descriptor)
return Universal.Real;
function Get_Hi_Bound (The_Fixed : Fixed_Type_Descriptor)
return Universal.Real;
type Fixed_Type_Array is
array (Positive range <>) of Fixed_Type_Descriptor;
Dynamic_Size : constant Integer := -1;
subtype Bits is Integer range Dynamic_Size .. Integer'Last;
subtype Scalar_Bits is Bits range 0 .. 256;
----------
type Object is private;
function Null_Object return Object;
function Is_Null (The_Object : Object) return Boolean;
function Build (Standard_Version : Integer;
Integer_Types : Integer_Type_Array;
Float_Types : Float_Type_Array;
Duration_Type : Fixed_Type_Descriptor;
For_Target : String) return Object;
-- Types should appear in increasing size order in their corresponding
-- arrays.
Build_Failed : exception;
procedure Check (Standard_Version : Integer;
Integer_Types : Integer_Type_Array;
Float_Types : Float_Type_Array;
Duration_Type : Fixed_Type_Descriptor;
Status : in out Simple_Status.Condition);
procedure Display (The_Object : Object);
function Get_Standard_Version (The_Object : Object) return Integer;
function Get_Integer_Types
(The_Object : Object) return Integer_Type_Array;
function Get_Float_Types (The_Object : Object) return Float_Type_Array;
function Get_Duration (The_Object : Object)
return Fixed_Type_Descriptor;
private
type Real_Node is new Eniversal.Real;
type Universal_Real is access Real_Node;
pragma Segmented_Heap (Universal_Real);
type Integer_Type_Descriptor_Record is
record
Name : Text.Item;
Size : Natural;
Lo_Bound : Universal.Integer;
Hi_Bound : Universal.Integer;
end record;
type Integer_Type_Descriptor is access Integer_Type_Descriptor_Record;
pragma Segmented_Heap (Integer_Type_Descriptor);
type Float_Type_Descriptor_Record is
record
Name : Text.Item;
Digitz : Positive;
Size : Positive;
Lo_Bound : Universal_Real;
Hi_Bound : Universal_Real;
Safe_Emax : Integer;
Machine_Emax : Integer;
Machine_Emin : Integer;
Machine_Radix : Positive;
Machine_Mantissa : Positive;
Machine_Rounds : Boolean;
Machine_Overflows : Boolean;
end record;
type Float_Type_Descriptor is access Float_Type_Descriptor_Record;
pragma Segmented_Heap (Float_Type_Descriptor);
type Fixed_Type_Descriptor_Record is
record
Name : Text.Item;
Size : Positive;
Scale : Integer;
Lo_Bound : Universal_Real;
Hi_Bound : Universal_Real;
end record;
type Fixed_Type_Descriptor is access Fixed_Type_Descriptor_Record;
pragma Segmented_Heap (Fixed_Type_Descriptor);
type Integer_Type_Array_Ptr is access Integer_Type_Array;
pragma Segmented_Heap (Integer_Type_Array_Ptr);
type Float_Type_Array_Ptr is access Float_Type_Array;
pragma Segmented_Heap (Float_Type_Array_Ptr);
type Fixed_Type_Array_Ptr is access Fixed_Type_Array;
pragma Segmented_Heap (Fixed_Type_Array_Ptr);
type Object_Record is
record
Standard_Version : Integer;
Integer_Types : Integer_Type_Array_Ptr;
Float_Types : Float_Type_Array_Ptr;
Duration_Type : Fixed_Type_Descriptor;
end record;
type Object is access Object_Record;
pragma Segmented_Heap (Object);
end Predefined_Environment_Characteristics;
---------------------------------------------------------------------
package Pragma_Characteristics is
package Pragmas renames Pragma_Characteristics;
-- The absence or presence of impl-defined pragmas cannot alter the
-- legality of text outside the the pragma. (LRM 2.8)
-- An argument to a pragma can either be a name or an expression (LRM 2.8)
-- Names appearing as pragma args can only be a name visible at the
-- place of the pragma or an identifier specific to the pragma.
type Ada_Pragma is (Controlled_Pragma, Elaborate_Pragma, Inline_Pragma,
Interface_Pragma, List_Pragma, Memory_Size_Pragma,
Optimize_Pragma, Pack_Pragma, Page_Pragma,
Priority_Pragma, Shared_Pragma, Storage_Unit_Pragma,
Suppress_Pragma, System_Name_Pragma);
type Location_Kind is (Context_Clause, Comp_Unit,
Statement, Declaration, Task_Spec);
type Ada_Pragma_Array is array (Ada_Pragma) of Boolean;
No_Ada_Pragmas : constant Ada_Pragma_Array := (others => False);
All_Ada_Pragmas : constant Ada_Pragma_Array := (others => True);
type Location_Array is array (Location_Kind) of Boolean;
No_Locations : constant Location_Array := (others => False);
All_Locations : constant Location_Array := (others => True);
----------
type Argument is private;
-- A pragma Argument. Arguments are broken down into two kinds,
-- NAME Arguments and EXPRESSION arguments.
-- NAME Arguments are for those arguments that are important for
-- their identity rather than their value. They are what ada
-- defines as 'Names'.
-- The ada pragmas Pack, Elaborate, and Inline each have one
-- Name Argument.
-- EXPRESSION arguments are values.
-- The ada pragmas Memory_Size, Storage_Unit, and Priority each
-- have one Expression Argument.
-- Some pragma arguments, such as the arguments to pragmas Optimize
-- and List, can be pragma-dependent identifiers that appear nowhere
-- else in the program. "Special Identifier" arguments are considered
-- NAME Arguments.
-- Object identifiers and function identifiers can represent both
-- Names and Expressions. It is important to determine whether the
-- VALUE or the IDENTITY of the entity is utilized by the pragma.
-- A pragma will be 'applied' to all entities supplied as Name
-- Arguments of that pragma. This may be relevent if the
-- pragma shows up somewhere as a 'Required' or 'Prohibited' pragma.
function Is_Null (The_Argument : Argument) return Boolean;
-- A null argument means semantics should assume nothing about the
-- argument and allow anything to be placed in that slot.
function Build_Name_Argument
(Name : String;
Valid_Objects : Checking.Object_Set :=
Checking.Null_Object_Set;
Valid_Miscellaneous_Names :
Checking.Miscellaneous_Name_Set :=
Checking.Null_Miscellaneous_Name_Set;
Valid_Types : Checking.Type_Set := Checking.Null_Type_Set;
Valid_Special_Identifiers : Checking.Identifier_Array :=
Checking.No_Identifiers;
For_Target : String) return Argument;
function Build_Expression_Argument
(Name : String;
Valid_Expressions : Checking.Expression;
For_Target : String) return Argument;
function Get_Name (The_Argument : Argument) return String;
function Is_Name_Argument (The_Argument : Argument) return Boolean;
function Get_Valid_Objects (The_Argument : Argument)
return Checking.Object_Set;
function Get_Valid_Miscellaneous_Names
(The_Argument : Argument)
return Checking.Miscellaneous_Name_Set;
function Get_Valid_Types (The_Argument : Argument)
return Checking.Type_Set;
function Get_Valid_Special_Identifiers
(The_Argument : Argument) return Checking.Identifier_Array;
function Get_Valid_Expressions
(The_Argument : Argument) return Checking.Expression;
type Argument_Array is array (Positive range <>) of Argument;
function No_Arguments return Argument_Array;
----------
type Target_Pragma is private;
-- Target_Pragmas repesent pragmas defined by the target compiler.
-- The Valid_Locations are where in a program the pragma is
-- allowed. (The Pragma_Locations type is obtained from
-- the allowed locations of Ada pragmas).
-- The last_required_argument field should equal the number
-- of arguments a pragma has, unless some are optional. Only
-- arguments at the end of the list are allowed to be optional.
function Is_Null (The_Target_Pragma : Target_Pragma) return Boolean;
function Build (Name : String;
Valid_Locations : Location_Array;
Arguments : Argument_Array;
Last_Required_Argument : Natural;
For_Target : String) return Target_Pragma;
function Get_Name (The_Target_Pragma : Target_Pragma) return String;
function Get_Valid_Locations
(The_Target_Pragma : Target_Pragma) return Location_Array;
function Get_Arguments
(The_Target_Pragma : Target_Pragma) return Argument_Array;
function Get_Last_Required_Argument
(The_Target_Pragma : Target_Pragma) return Natural;
type Target_Pragma_Array is array (Positive range <>) of Target_Pragma;
function No_Target_Pragmas return Target_Pragma_Array;
----------
type Object is private;
function Null_Object return Object;
function Is_Null (The_Object : Object) return Boolean;
function Build (Supported_Ada_Pragmas : Ada_Pragma_Array;
Target_Pragmas : Target_Pragma_Array :=
Pragmas.No_Target_Pragmas;
Interface_Languages : Checking.Identifier_Array :=
Checking.No_Identifiers;
For_Target : String) return Object;
-- Interface_Languages is the set of languages allowed in usages of
-- pragma Interface.
Build_Failed : exception;
procedure Check (Supported_Ada_Pragmas : Ada_Pragma_Array;
Target_Pragmas : Target_Pragma_Array;
Status : in out Simple_Status.Condition);
procedure Display (The_Object : Object);
function Get_Supported_Ada_Pragmas
(The_Object : Object) return Ada_Pragma_Array;
function Get_Target_Pragmas
(The_Object : Object) return Target_Pragma_Array;
function Get_Interface_Languages (The_Object : Object)
return Checking.Identifier_Array;
private
type Identifier_Array_Ptr is access Checking.Identifier_Array;
pragma Segmented_Heap (Identifier_Array_Ptr);
type Argument_Record (Is_Name : Boolean := True) is
record
Name : Text.Item;
case Is_Name is
when True =>
Valid_Objects : Checking.Object_Set;
Valid_Miscellaneous_Names :
Checking.Miscellaneous_Name_Set;
Valid_Types : Checking.Type_Set;
Valid_Special_Identifiers : Identifier_Array_Ptr;
when False =>
Valid_Expressions : Checking.Expression;
end case;
end record;
type Argument is access Argument_Record;
pragma Segmented_Heap (Argument);
type Argument_Array_Ptr is access Argument_Array;
pragma Segmented_Heap (Argument_Array_Ptr);
type Target_Pragma_Record is
record
Name : Text.Item;
Valid_Locations : Location_Array;
Arguments : Argument_Array_Ptr;
Last_Required_Argument : Natural;
end record;
type Target_Pragma is access Target_Pragma_Record;
pragma Segmented_Heap (Target_Pragma);
type Target_Pragma_Array_Ptr is access Target_Pragma_Array;
pragma Segmented_Heap (Target_Pragma_Array_Ptr);
type Object_Record is
record
Supported_Ada_Pragmas : Ada_Pragma_Array;
Target_Pragmas : Target_Pragma_Array_Ptr;
Interface_Languages : Identifier_Array_Ptr;
end record;
type Object is access Object_Record;
pragma Segmented_Heap (Object);
end Pragma_Characteristics;
----------------------------------------------------------------------
-- Attributes
package Attribute_Characteristics is
package Attributes renames Attribute_Characteristics;
-- Attributes can be:
-- a basic operation returning a value
-- a function
-- a type
-- a range
-- (LRM 4.1.4)
type Result_Kind is (Value_Result, Type_Result, Range_Result);
----------
type Prefix is private;
-- A Prefix represents the prefix of a target defined attribute.
-- eg. 'Foo' in
-- X := Foo'Bar (4);
-- The customizer must specify the kinds of ada names that can appear
-- as a prefix for each attribute.
function Is_Null (The_Prefix : Prefix) return Boolean;
-- A null prefix means that semantics should place no restrictions
-- on a prefix for the given attribute.
function Build (Valid_Objects : Checking.Object_Set :=
Checking.Null_Object_Set;
Valid_Miscellaneous_Names :
Checking.Miscellaneous_Name_Set :=
Checking.Null_Miscellaneous_Name_Set;
Valid_Types : Checking.Type_Set :=
Checking.Null_Type_Set;
For_Target : String) return Prefix;
function Get_Valid_Objects (The_Prefix : Prefix)
return Checking.Object_Set;
function Get_Valid_Miscellaneous_Names
(The_Prefix : Prefix) return Checking.
Miscellaneous_Name_Set;
function Get_Valid_Types (The_Prefix : Prefix) return Checking.Type_Set;
----------
type Result is private;
-- A Result represents the result of a target-defined attribute.
-- Some attributes return ranges, some return types, and most return
-- single values. R1000 semantics does not fully support target
-- attributes with range or type results at this time.
function Is_Null (The_Result : Result) return Boolean;
function Prefix_Value (For_Target : String) return Result;
function Prefix_Range (For_Target : String) return Result;
function Build_With_Value_Result
(Type_Name : String; For_Target : String) return Result;
function Build_With_Range_Result
(Type_Name : String; For_Target : String) return Result;
function Build_With_Type_Result (For_Target : String) return Result;
function Get_Result_Kind (The_Result : Result) return Result_Kind;
function Is_Prefix_Type (The_Result : Result) return Boolean;
function Get_Name (The_Result : Result) return String;
----------
type Designator is private;
-- Ada defines the Designator of an attribute expression such as
-- "Foo'Bar (Baz)" to be the attribute name and the optional parameter
-- (In this case, "Bar (Baz)". However, the Rcf makes the
-- attribute name a separate component of an abstract attribute, so a
-- Designator represents only the parameter.
function Null_Designator return Designator;
function Is_Null (The_Designator : Designator) return Boolean;
-- Null designator implies no parameter.
function Prefix_Designator (For_Target : String) return Designator;
-- A "Prefix" designator means the parameter type is the type of
-- the prefix. If the prefix is not a type, it is illegal to declare
-- a prefix_designator.
function Build (Function_Parameter : Checking.Expression;
For_Target : String) return Designator;
function Is_Prefix_Type (The_Designator : Designator) return Boolean;
function Get_Function_Parameter
(The_Designator : Designator) return Checking.Expression;
----------
type Attribute is private;
function Is_Null (The_Attribute : Attribute) return Boolean;
function Build (The_Name : String;
The_Prefix : Prefix;
The_Result : Result;
The_Designator : Designator :=
Attributes.Null_Designator;
For_Target : String) return Attribute;
function Get_Name (The_Attribute : Attribute) return String;
function Get_Prefix (The_Attribute : Attribute) return Prefix;
function Get_Result (The_Attribute : Attribute) return Result;
function Get_Designator (The_Attribute : Attribute) return Designator;
type Attribute_Array is array (Positive range <>) of Attribute;
function No_Attributes return Attribute_Array;
----------
type Object is private;
function Null_Object return Object;
function Is_Null (The_Object : Object) return Boolean;
function Build (Attribute_List : Attribute_Array :=
Attributes.No_Attributes;
For_Target : String) return Object;
Build_Failed : exception;
procedure Check (Attributes : Attribute_Array;
Status : in out Simple_Status.Condition);
procedure Display (The_Object : Object);
function Get_Attributes (The_Object : Object) return Attribute_Array;
private
type Prefix_Record is
record
Valid_Objects : Checking.Object_Set;
Valid_Miscellaneous_Names : Checking.Miscellaneous_Name_Set;
Valid_Types : Checking.Type_Set;
end record;
type Prefix is access Prefix_Record;
pragma Segmented_Heap (Prefix);
type Result_Record (The_Kind : Result_Kind := Value_Result;
Is_Prefix_Type : Boolean := False) is
record
case The_Kind is
when Type_Result =>
null;
when Value_Result | Range_Result =>
case Is_Prefix_Type is
when True =>
null;
when False =>
Name : Text.Item;
end case;
end case;
end record;
type Result is access Result_Record;
pragma Segmented_Heap (Result);
type Designator_Record (Is_Prefix_Type : Boolean := False) is
record
case Is_Prefix_Type is
when True =>
null;
when False =>
Function_Parameter : Checking.Expression;
end case;
end record;
type Designator is access Designator_Record;
pragma Segmented_Heap (Designator);
type Attribute_Record is
record
The_Name : Text.Item;
The_Prefix : Prefix;
The_Result : Result;
The_Designator : Designator;
end record;
type Attribute is access Attribute_Record;
pragma Segmented_Heap (Attribute);
type Object is access Attribute_Array;
pragma Segmented_Heap (Object);
end Attribute_Characteristics;
----------------------------------------------------------------------
package Rep_Spec_Characteristics is
package Rep_Specs renames Rep_Spec_Characteristics;
Last_Address_Clause_Object :
Checking.Miscellaneous_Name_Kind := Checking.Entry_Kind;
subtype Address_Clause_Miscellaneous_Name_Kind is
Checking.Miscellaneous_Name_Kind
range Checking.Miscellaneous_Name_Kind'First ..
Last_Address_Clause_Object;
type Address_Clause_Miscellaneous_Name_Kind_Array is
array (Address_Clause_Miscellaneous_Name_Kind) of Boolean;
subtype Address_Clause_Miscellaneous_Name_Set is
Address_Clause_Miscellaneous_Name_Kind_Array;
----------
type Address_Clause_Data is private;
function Null_Address_Clause_Data return Address_Clause_Data;
function Is_Null (The_Address_Clause_Data : Address_Clause_Data)
return Boolean;
function Build (Valid_Objects : Checking.Object_Set :=
Checking.Null_Object_Set;
Valid_Miscellaneous_Names :
Checking.Miscellaneous_Name_Set :=
Checking.Null_Miscellaneous_Name_Set;
For_Target : String) return Address_Clause_Data;
function Get_Valid_Objects
(The_Address_Clause_Data : Address_Clause_Data)
return Checking.Object_Set;
function Get_Valid_Miscellaneous_Names
(The_Address_Clause_Data : Address_Clause_Data)
return Checking.Miscellaneous_Name_Set;
----------
type Storage_Size_Data is private;
-- Storage_size_data describes the restrictions placed on the usage
-- of storage_size representation clauses.
function Null_Storage_Size_Data return Storage_Size_Data;
-- Null Storage_Size_data means that no target-dependent checks will
-- be made on storage_size specifications.
function Is_Null
(The_Storage_Size_Data : Storage_Size_Data) return Boolean;
function Build (Allowed_For_Task : Boolean := False;
Allowed_For_Access_Types : Boolean := False;
Allowed_With_Size_Specs : Boolean := False;
Task_Upper_Bound : Universal.Integer := Universal.Zero;
Access_Upper_Bound :
Universal.Integer := Universal.Zero;
For_Target : String) return Storage_Size_Data;
function Is_Allowed_For_Tasks
(The_Storage_Size_Data : Storage_Size_Data) return Boolean;
function Is_Allowed_For_Access_Types
(The_Storage_Size_Data : Storage_Size_Data) return Boolean;
function Is_Allowed_With_Size_Specs
(The_Storage_Size_Data : Storage_Size_Data) return Boolean;
function Get_Task_Upper_Bound
(The_Storage_Size_Data : Storage_Size_Data)
return Universal.Integer;
function Get_Access_Upper_Bound
(The_Storage_Size_Data : Storage_Size_Data)
return Universal.Integer;
----------
type Object is private;
function Null_Object return Object;
function Is_Null (The_Object : Object) return Boolean;
function Build (Address_Clause_Info : Address_Clause_Data :=
Rep_Specs.Null_Address_Clause_Data;
Storage_Size_Info : Storage_Size_Data :=
Rep_Specs.Null_Storage_Size_Data;
For_Target : String) return Object;
Build_Failed : exception;
procedure Check (Address_Clause_Info : Address_Clause_Data;
Storage_Size_Info : Storage_Size_Data;
Status : in out Simple_Status.Condition);
procedure Display (The_Object : Object);
function Get_Address_Clause_Info
(The_Object : Object) return Address_Clause_Data;
function Get_Storage_Size_Info
(The_Object : Object) return Storage_Size_Data;
private
type Address_Clause_Data_Record is
record
Valid_Objects : Checking.Object_Set;
Valid_Miscellaneous_Names : Checking.Miscellaneous_Name_Set;
end record;
type Address_Clause_Data is access Address_Clause_Data_Record;
pragma Segmented_Heap (Address_Clause_Data);
type Storage_Size_Data_Record is
record
Allowed_For_Tasks : Boolean := False;
Allowed_For_Access_Types : Boolean := False;
Allowed_With_Size_Spec : Boolean := False;
Task_Upper_Bound : Universal.Integer := Universal.Zero;
Access_Upper_Bound : Universal.Integer := Universal.Zero;
end record;
type Storage_Size_Data is access Storage_Size_Data_Record;
pragma Segmented_Heap (Storage_Size_Data);
type Object_Record is
record
Address_Clause_Info : Address_Clause_Data;
Storage_Size_Info : Storage_Size_Data;
end record;
type Object is access Object_Record;
pragma Segmented_Heap (Object);
end Rep_Spec_Characteristics;
----------------------------------------------------------------------
pragma Module_Name (4, 4143);
pragma Bias_Key (32);
end Semantic_Characteristics;
nblk1=33
nid=0
hdr6=66
[0x00] rec0=25 rec1=00 rec2=01 rec3=03c
[0x01] rec0=17 rec1=00 rec2=02 rec3=01a
[0x02] rec0=19 rec1=00 rec2=03 rec3=046
[0x03] rec0=11 rec1=00 rec2=04 rec3=094
[0x04] rec0=18 rec1=00 rec2=05 rec3=040
[0x05] rec0=14 rec1=00 rec2=06 rec3=030
[0x06] rec0=18 rec1=00 rec2=07 rec3=082
[0x07] rec0=17 rec1=00 rec2=08 rec3=060
[0x08] rec0=17 rec1=00 rec2=09 rec3=078
[0x09] rec0=17 rec1=00 rec2=0a rec3=046
[0x0a] rec0=16 rec1=00 rec2=0b rec3=01c
[0x0b] rec0=17 rec1=00 rec2=0c rec3=010
[0x0c] rec0=16 rec1=00 rec2=0d rec3=024
[0x0d] rec0=16 rec1=00 rec2=0e rec3=058
[0x0e] rec0=14 rec1=00 rec2=0f rec3=00c
[0x0f] rec0=18 rec1=00 rec2=10 rec3=036
[0x10] rec0=1b rec1=00 rec2=11 rec3=058
[0x11] rec0=1c rec1=00 rec2=12 rec3=008
[0x12] rec0=1a rec1=00 rec2=13 rec3=078
[0x13] rec0=16 rec1=00 rec2=14 rec3=06c
[0x14] rec0=12 rec1=00 rec2=15 rec3=040
[0x15] rec0=17 rec1=00 rec2=16 rec3=03e
[0x16] rec0=15 rec1=00 rec2=17 rec3=042
[0x17] rec0=1e rec1=00 rec2=18 rec3=020
[0x18] rec0=16 rec1=00 rec2=19 rec3=008
[0x19] rec0=19 rec1=00 rec2=1a rec3=054
[0x1a] rec0=19 rec1=00 rec2=1b rec3=04e
[0x1b] rec0=15 rec1=00 rec2=1c rec3=064
[0x1c] rec0=18 rec1=00 rec2=1d rec3=008
[0x1d] rec0=14 rec1=00 rec2=1e rec3=008
[0x1e] rec0=14 rec1=00 rec2=1f rec3=03c
[0x1f] rec0=14 rec1=00 rec2=20 rec3=088
[0x20] rec0=18 rec1=00 rec2=21 rec3=030
[0x21] rec0=18 rec1=00 rec2=22 rec3=00e
[0x22] rec0=17 rec1=00 rec2=23 rec3=04c
[0x23] rec0=19 rec1=00 rec2=24 rec3=034
[0x24] rec0=1b rec1=00 rec2=25 rec3=030
[0x25] rec0=1b rec1=00 rec2=26 rec3=02c
[0x26] rec0=14 rec1=00 rec2=27 rec3=056
[0x27] rec0=16 rec1=00 rec2=28 rec3=022
[0x28] rec0=17 rec1=00 rec2=29 rec3=04e
[0x29] rec0=1a rec1=00 rec2=2a rec3=05a
[0x2a] rec0=1c rec1=00 rec2=2b rec3=010
[0x2b] rec0=1c rec1=00 rec2=2c rec3=01c
[0x2c] rec0=1f rec1=00 rec2=2d rec3=026
[0x2d] rec0=16 rec1=00 rec2=2e rec3=02e
[0x2e] rec0=16 rec1=00 rec2=2f rec3=09e
[0x2f] rec0=17 rec1=00 rec2=30 rec3=03a
[0x30] rec0=19 rec1=00 rec2=31 rec3=044
[0x31] rec0=16 rec1=00 rec2=32 rec3=024
[0x32] rec0=0b rec1=00 rec2=33 rec3=000
tail 0x21718a08c83637bf3e2f7 0x42a00088462060003