2009-04-09 Robert Dewar <dewar@adacore.com>
+ * sem_aggr.adb, exp_ch5.adb, sem_ch3.adb, exp_atag.adb, layout.adb,
+ sem_dist.adb, exp_ch7.adb, sem_ch5.adb, sem_type.adb, exp_imgv.adb,
+ exp_util.adb, sem_aux.adb, sem_aux.ads, exp_attr.adb, exp_ch9.adb,
+ sem_ch7.adb, inline.adb, fe.h, sem_ch9.adb, exp_code.adb, einfo.adb,
+ einfo.ads, exp_pakd.adb, checks.adb, sem_ch12.adb, exp_smem.adb,
+ tbuild.adb, freeze.adb, sem_util.adb, sem_res.adb, sem_attr.adb,
+ exp_dbug.adb, sem_case.adb, exp_tss.adb, exp_ch4.adb, exp_ch6.adb,
+ sem_smem.adb, sem_ch4.adb, sem_mech.adb, sem_ch6.adb, exp_disp.adb,
+ sem_ch8.adb, exp_aggr.adb, sem_eval.adb, sem_cat.adb, exp_dist.adb,
+ sem_ch13.adb, exp_strm.adb, lib-xref.adb, sem_disp.adb, exp_ch3.adb:
+ Reorganize einfo/sem_aux, moving routines from einfo to sem_aux
+
+2009-04-09 Robert Dewar <dewar@adacore.com>
+
* exp_util.adb (Silly_Boolean_Array_Xor_Test): Simplify existing code.
* atree.h: Add Elist26
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
return Rep_Clause (Id, Name_Alignment);
end Alignment_Clause;
- ----------------------
- -- Ancestor_Subtype --
- ----------------------
-
- function Ancestor_Subtype (Id : E) return E is
- begin
- -- If this is first subtype, or is a base type, then there is no
- -- ancestor subtype, so we return Empty to indicate this fact.
-
- if Is_First_Subtype (Id) or else Id = Base_Type (Id) then
- return Empty;
- end if;
-
- declare
- D : constant Node_Id := Declaration_Node (Id);
-
- begin
- -- If we have a subtype declaration, get the ancestor subtype
-
- if Nkind (D) = N_Subtype_Declaration then
- if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
- return Entity (Subtype_Mark (Subtype_Indication (D)));
- else
- return Entity (Subtype_Indication (D));
- end if;
-
- -- If not, then no subtype indication is available
-
- else
- return Empty;
- end if;
- end;
- end Ancestor_Subtype;
-
-------------------
-- Append_Entity --
-------------------
Set_Last_Entity (Id => V, V => Id);
end Append_Entity;
- --------------------
- -- Available_View --
- --------------------
-
- function Available_View (Id : E) return E is
- begin
- if Is_Incomplete_Type (Id)
- and then Present (Non_Limited_View (Id))
- then
- -- The non-limited view may itself be an incomplete type, in
- -- which case get its full view.
-
- return Get_Full_View (Non_Limited_View (Id));
-
- elsif Is_Class_Wide_Type (Id)
- and then Is_Incomplete_Type (Etype (Id))
- and then Present (Non_Limited_View (Etype (Id)))
- then
- return Class_Wide_Type (Non_Limited_View (Etype (Id)));
-
- else
- return Id;
- end if;
- end Available_View;
-
---------------
-- Base_Type --
---------------
end if;
end Component_Alignment;
- --------------------
- -- Constant_Value --
- --------------------
-
- function Constant_Value (Id : E) return N is
- D : constant Node_Id := Declaration_Node (Id);
- Full_D : Node_Id;
-
- begin
- -- If we have no declaration node, then return no constant value.
- -- Not clear how this can happen, but it does sometimes ???
- -- To investigate, remove this check and compile discrim_po.adb.
-
- if No (D) then
- return Empty;
-
- -- Normal case where a declaration node is present
-
- elsif Nkind (D) = N_Object_Renaming_Declaration then
- return Renamed_Object (Id);
-
- -- If this is a component declaration whose entity is constant, it
- -- is a prival within a protected function. It does not have
- -- a constant value.
-
- elsif Nkind (D) = N_Component_Declaration then
- return Empty;
-
- -- If there is an expression, return it
-
- elsif Present (Expression (D)) then
- return (Expression (D));
-
- -- For a constant, see if we have a full view
-
- elsif Ekind (Id) = E_Constant
- and then Present (Full_View (Id))
- then
- Full_D := Parent (Full_View (Id));
-
- -- The full view may have been rewritten as an object renaming
-
- if Nkind (Full_D) = N_Object_Renaming_Declaration then
- return Name (Full_D);
- else
- return Expression (Full_D);
- end if;
-
- -- Otherwise we have no expression to return
-
- else
- return Empty;
- end if;
- end Constant_Value;
-
----------------------
-- Declaration_Node --
----------------------
end if;
end Designated_Type;
- -----------------------------
- -- Enclosing_Dynamic_Scope --
- -----------------------------
-
- function Enclosing_Dynamic_Scope (Id : E) return E is
- S : Entity_Id;
-
- begin
- -- The following test is an error defense against some syntax
- -- errors that can leave scopes very messed up.
-
- if Id = Standard_Standard then
- return Id;
- end if;
-
- -- Normal case, search enclosing scopes
-
- -- Note: the test for Present (S) should not be required, it is a
- -- defence against an ill-formed tree.
-
- S := Scope (Id);
- loop
- -- If we somehow got an empty value for Scope, the tree must be
- -- malformed. Rather than blow up we return Standard in this case.
-
- if No (S) then
- return Standard_Standard;
-
- -- Quit if we get to standard or a dynamic scope
-
- elsif S = Standard_Standard
- or else Is_Dynamic_Scope (S)
- then
- return S;
-
- -- Otherwise keep climbing
-
- else
- S := Scope (S);
- end if;
- end loop;
- end Enclosing_Dynamic_Scope;
-
----------------------
-- Entry_Index_Type --
----------------------
return Comp_Id;
end First_Component_Or_Discriminant;
- ------------------------
- -- First_Discriminant --
- ------------------------
-
- function First_Discriminant (Id : E) return E is
- Ent : Entity_Id;
-
- begin
- pragma Assert
- (Has_Discriminants (Id)
- or else Has_Unknown_Discriminants (Id));
-
- Ent := First_Entity (Id);
-
- -- The discriminants are not necessarily contiguous, because access
- -- discriminants will generate itypes. They are not the first entities
- -- either, because tag and controller record must be ahead of them.
-
- if Chars (Ent) = Name_uTag then
- Ent := Next_Entity (Ent);
- end if;
-
- if Chars (Ent) = Name_uController then
- Ent := Next_Entity (Ent);
- end if;
-
- -- Skip all hidden stored discriminants if any
-
- while Present (Ent) loop
- exit when Ekind (Ent) = E_Discriminant
- and then not Is_Completely_Hidden (Ent);
-
- Ent := Next_Entity (Ent);
- end loop;
-
- pragma Assert (Ekind (Ent) = E_Discriminant);
-
- return Ent;
- end First_Discriminant;
-
------------------
-- First_Formal --
------------------
end if;
end First_Formal_With_Extras;
- -------------------------------
- -- First_Stored_Discriminant --
- -------------------------------
-
- function First_Stored_Discriminant (Id : E) return E is
- Ent : Entity_Id;
-
- function Has_Completely_Hidden_Discriminant (Id : E) return Boolean;
- -- Scans the Discriminants to see whether any are Completely_Hidden
- -- (the mechanism for describing non-specified stored discriminants)
-
- ----------------------------------------
- -- Has_Completely_Hidden_Discriminant --
- ----------------------------------------
-
- function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is
- Ent : Entity_Id := Id;
-
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
-
- while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
- if Is_Completely_Hidden (Ent) then
- return True;
- end if;
-
- Ent := Next_Entity (Ent);
- end loop;
-
- return False;
- end Has_Completely_Hidden_Discriminant;
-
- -- Start of processing for First_Stored_Discriminant
-
- begin
- pragma Assert
- (Has_Discriminants (Id)
- or else Has_Unknown_Discriminants (Id));
-
- Ent := First_Entity (Id);
-
- if Chars (Ent) = Name_uTag then
- Ent := Next_Entity (Ent);
- end if;
-
- if Chars (Ent) = Name_uController then
- Ent := Next_Entity (Ent);
- end if;
-
- if Has_Completely_Hidden_Discriminant (Ent) then
-
- while Present (Ent) loop
- exit when Is_Completely_Hidden (Ent);
- Ent := Next_Entity (Ent);
- end loop;
-
- end if;
-
- pragma Assert (Ekind (Ent) = E_Discriminant);
-
- return Ent;
- end First_Stored_Discriminant;
-
- -------------------
- -- First_Subtype --
- -------------------
-
- function First_Subtype (Id : E) return E is
- B : constant Entity_Id := Base_Type (Id);
- F : constant Node_Id := Freeze_Node (B);
- Ent : Entity_Id;
-
- begin
- -- If the base type has no freeze node, it is a type in standard,
- -- and always acts as its own first subtype unless it is one of
- -- the predefined integer types. If the type is formal, it is also
- -- a first subtype, and its base type has no freeze node. On the other
- -- hand, a subtype of a generic formal is not its own first_subtype.
- -- Its base type, if anonymous, is attached to the formal type decl.
- -- from which the first subtype is obtained.
-
- if No (F) then
-
- if B = Base_Type (Standard_Integer) then
- return Standard_Integer;
-
- elsif B = Base_Type (Standard_Long_Integer) then
- return Standard_Long_Integer;
-
- elsif B = Base_Type (Standard_Short_Short_Integer) then
- return Standard_Short_Short_Integer;
-
- elsif B = Base_Type (Standard_Short_Integer) then
- return Standard_Short_Integer;
-
- elsif B = Base_Type (Standard_Long_Long_Integer) then
- return Standard_Long_Long_Integer;
-
- elsif Is_Generic_Type (Id) then
- if Present (Parent (B)) then
- return Defining_Identifier (Parent (B));
- else
- return Defining_Identifier (Associated_Node_For_Itype (B));
- end if;
-
- else
- return B;
- end if;
-
- -- Otherwise we check the freeze node, if it has a First_Subtype_Link
- -- then we use that link, otherwise (happens with some Itypes), we use
- -- the base type itself.
-
- else
- Ent := First_Subtype_Link (F);
-
- if Present (Ent) then
- return Ent;
- else
- return B;
- end if;
- end if;
- end First_Subtype;
-
-------------------------------------
-- Get_Attribute_Definition_Clause --
-------------------------------------
return Root_Type (Id) = Standard_Boolean;
end Is_Boolean_Type;
- ---------------------
- -- Is_By_Copy_Type --
- ---------------------
-
- function Is_By_Copy_Type (Id : E) return B is
- begin
- -- If Id is a private type whose full declaration has not been seen,
- -- we assume for now that it is not a By_Copy type. Clearly this
- -- attribute should not be used before the type is frozen, but it is
- -- needed to build the associated record of a protected type. Another
- -- place where some lookahead for a full view is needed ???
-
- return
- Is_Elementary_Type (Id)
- or else (Is_Private_Type (Id)
- and then Present (Underlying_Type (Id))
- and then Is_Elementary_Type (Underlying_Type (Id)));
- end Is_By_Copy_Type;
-
- --------------------------
- -- Is_By_Reference_Type --
- --------------------------
-
- -- This function knows too much semantics, it should be in sem_util ???
-
- function Is_By_Reference_Type (Id : E) return B is
- Btype : constant Entity_Id := Base_Type (Id);
-
- begin
- if Error_Posted (Id)
- or else Error_Posted (Btype)
- then
- return False;
-
- elsif Is_Private_Type (Btype) then
- declare
- Utyp : constant Entity_Id := Underlying_Type (Btype);
- begin
- if No (Utyp) then
- return False;
- else
- return Is_By_Reference_Type (Utyp);
- end if;
- end;
-
- elsif Is_Incomplete_Type (Btype) then
- declare
- Ftyp : constant Entity_Id := Full_View (Btype);
- begin
- if No (Ftyp) then
- return False;
- else
- return Is_By_Reference_Type (Ftyp);
- end if;
- end;
-
- elsif Is_Concurrent_Type (Btype) then
- return True;
-
- elsif Is_Record_Type (Btype) then
- if Is_Limited_Record (Btype)
- or else Is_Tagged_Type (Btype)
- or else Is_Volatile (Btype)
- then
- return True;
-
- else
- declare
- C : Entity_Id;
-
- begin
- C := First_Component (Btype);
- while Present (C) loop
- if Is_By_Reference_Type (Etype (C))
- or else Is_Volatile (Etype (C))
- then
- return True;
- end if;
-
- C := Next_Component (C);
- end loop;
- end;
-
- return False;
- end if;
-
- elsif Is_Array_Type (Btype) then
- return
- Is_Volatile (Btype)
- or else Is_By_Reference_Type (Component_Type (Btype))
- or else Is_Volatile (Component_Type (Btype))
- or else Has_Volatile_Components (Btype);
-
- else
- return False;
- end if;
- end Is_By_Reference_Type;
-
------------------------
-- Is_Constant_Object --
------------------------
K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter;
end Is_Constant_Object;
- ---------------------
- -- Is_Derived_Type --
- ---------------------
-
- function Is_Derived_Type (Id : E) return B is
- Par : Node_Id;
-
- begin
- if Is_Type (Id)
- and then Base_Type (Id) /= Root_Type (Id)
- and then not Is_Class_Wide_Type (Id)
- then
- if not Is_Numeric_Type (Root_Type (Id)) then
- return True;
-
- else
- Par := Parent (First_Subtype (Id));
-
- return Present (Par)
- and then Nkind (Par) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (Par)) =
- N_Derived_Type_Definition;
- end if;
-
- else
- return False;
- end if;
- end Is_Derived_Type;
-
--------------------
-- Is_Discriminal --
--------------------
and then Is_Entity_Attribute_Name (Attribute_Name (N)));
end Is_Entity_Name;
- ---------------------------
- -- Is_Indefinite_Subtype --
- ---------------------------
-
- function Is_Indefinite_Subtype (Id : Entity_Id) return B is
- K : constant Entity_Kind := Ekind (Id);
-
- begin
- if Is_Constrained (Id) then
- return False;
-
- elsif K in Array_Kind
- or else K in Class_Wide_Kind
- or else Has_Unknown_Discriminants (Id)
- then
- return True;
-
- -- Known discriminants: indefinite if there are no default values
-
- elsif K in Record_Kind
- or else Is_Incomplete_Or_Private_Type (Id)
- or else Is_Concurrent_Type (Id)
- then
- return (Has_Discriminants (Id)
- and then No (Discriminant_Default_Value (First_Discriminant (Id))));
-
- else
- return False;
- end if;
- end Is_Indefinite_Subtype;
-
- --------------------------------
- -- Is_Inherently_Limited_Type --
- --------------------------------
-
- function Is_Inherently_Limited_Type (Id : E) return B is
- Btype : constant Entity_Id := Base_Type (Id);
-
- begin
- if Is_Private_Type (Btype) then
- declare
- Utyp : constant Entity_Id := Underlying_Type (Btype);
- begin
- if No (Utyp) then
- return False;
- else
- return Is_Inherently_Limited_Type (Utyp);
- end if;
- end;
-
- elsif Is_Concurrent_Type (Btype) then
- return True;
-
- elsif Is_Record_Type (Btype) then
- if Is_Limited_Record (Btype) then
- return not Is_Interface (Btype)
- or else Is_Protected_Interface (Btype)
- or else Is_Synchronized_Interface (Btype)
- or else Is_Task_Interface (Btype);
-
- elsif Is_Class_Wide_Type (Btype) then
- return Is_Inherently_Limited_Type (Root_Type (Btype));
-
- else
- declare
- C : Entity_Id;
-
- begin
- C := First_Component (Btype);
- while Present (C) loop
- if Is_Inherently_Limited_Type (Etype (C)) then
- return True;
- end if;
-
- C := Next_Component (C);
- end loop;
- end;
-
- return False;
- end if;
-
- elsif Is_Array_Type (Btype) then
- return Is_Inherently_Limited_Type (Component_Type (Btype));
-
- else
- return False;
- end if;
- end Is_Inherently_Limited_Type;
-
- ---------------------
- -- Is_Limited_Type --
- ---------------------
-
- function Is_Limited_Type (Id : E) return B is
- Btype : constant E := Base_Type (Id);
- Rtype : constant E := Root_Type (Btype);
-
- begin
- if not Is_Type (Id) then
- return False;
-
- elsif Ekind (Btype) = E_Limited_Private_Type
- or else Is_Limited_Composite (Btype)
- then
- return True;
-
- elsif Is_Concurrent_Type (Btype) then
- return True;
-
- -- The Is_Limited_Record flag normally indicates that the type is
- -- limited. The exception is that a type does not inherit limitedness
- -- from its interface ancestor. So the type may be derived from a
- -- limited interface, but is not limited.
-
- elsif Is_Limited_Record (Id)
- and then not Is_Interface (Id)
- then
- return True;
-
- -- Otherwise we will look around to see if there is some other reason
- -- for it to be limited, except that if an error was posted on the
- -- entity, then just assume it is non-limited, because it can cause
- -- trouble to recurse into a murky erroneous entity!
-
- elsif Error_Posted (Id) then
- return False;
-
- elsif Is_Record_Type (Btype) then
-
- if Is_Limited_Interface (Id) then
- return True;
-
- -- AI-419: limitedness is not inherited from a limited interface
-
- elsif Is_Limited_Record (Rtype) then
- return not Is_Interface (Rtype)
- or else Is_Protected_Interface (Rtype)
- or else Is_Synchronized_Interface (Rtype)
- or else Is_Task_Interface (Rtype);
-
- elsif Is_Class_Wide_Type (Btype) then
- return Is_Limited_Type (Rtype);
-
- else
- declare
- C : E;
-
- begin
- C := First_Component (Btype);
- while Present (C) loop
- if Is_Limited_Type (Etype (C)) then
- return True;
- end if;
-
- C := Next_Component (C);
- end loop;
- end;
-
- return False;
- end if;
-
- elsif Is_Array_Type (Btype) then
- return Is_Limited_Type (Component_Type (Btype));
-
- else
- return False;
- end if;
- end Is_Limited_Type;
-
-----------------------------------
-- Is_Package_Or_Generic_Package --
-----------------------------------
end if;
end Number_Dimensions;
- --------------------------
- -- Number_Discriminants --
- --------------------------
-
- function Number_Discriminants (Id : E) return Pos is
- N : Int;
- Discr : Entity_Id;
-
- begin
- N := 0;
- Discr := First_Discriminant (Id);
- while Present (Discr) loop
- N := N + 1;
- Discr := Next_Discriminant (Discr);
- end loop;
-
- return N;
- end Number_Discriminants;
-
--------------------
-- Number_Entries --
--------------------
return Kind;
end Subtype_Kind;
- -------------------------
- -- First_Tag_Component --
- -------------------------
-
- function First_Tag_Component (Id : E) return E is
- Comp : Entity_Id;
- Typ : Entity_Id := Id;
-
- begin
- pragma Assert (Is_Tagged_Type (Typ));
-
- if Is_Class_Wide_Type (Typ) then
- Typ := Root_Type (Typ);
- end if;
-
- if Is_Private_Type (Typ) then
- Typ := Underlying_Type (Typ);
-
- -- If the underlying type is missing then the source program has
- -- errors and there is nothing else to do (the full-type declaration
- -- associated with the private type declaration is missing).
-
- if No (Typ) then
- return Empty;
- end if;
- end if;
-
- Comp := First_Entity (Typ);
- while Present (Comp) loop
- if Is_Tag (Comp) then
- return Comp;
- end if;
-
- Comp := Next_Entity (Comp);
- end loop;
-
- -- No tag component found
-
- return Empty;
- end First_Tag_Component;
-
- ------------------------
- -- Next_Tag_Component --
- ------------------------
-
- function Next_Tag_Component (Id : E) return E is
- Comp : Entity_Id;
-
- begin
- pragma Assert (Is_Tag (Id));
-
- Comp := Next_Entity (Id);
- while Present (Comp) loop
- if Is_Tag (Comp) then
- pragma Assert (Chars (Comp) /= Name_uTag);
- return Comp;
- end if;
-
- Comp := Next_Entity (Comp);
- end loop;
-
- -- No tag component found
-
- return Empty;
- end Next_Tag_Component;
-
---------------------
-- Type_High_Bound --
---------------------
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
--- Ancestor_Subtype (synthesized)
--- Applies to all type and subtype entities. If the argument is a
--- subtype then it returns the subtype or type from which the subtype
--- was obtained, otherwise it returns Empty.
-
--- Available_View (synthesized)
--- Applies to types that have the With_Type flag set. Returns the
--- non-limited view of the type, if available, otherwise the type
--- itself. For class-wide types, there is no direct link in the tree,
--- so we have to retrieve the class-wide type of the non-limited view
--- of the Etype.
-
-- Associated_Formal_Package (Node12)
-- Present in packages that are the actuals of formal_packages. Points
-- to the entity in the declaration for the formal package.
-- Component_Type (Node20) [implementation base type only]
-- Present in array types and string types. References component type.
--- Constant_Value (synthesized)
--- Applies to variables, constants, named integers, and named reals.
--- Obtains the initialization expression for the entity. Will return
--- Empty for a deferred constant whose full view is not available
--- or in some other cases of internal entities, which cannot be treated
--- as constants from the point of view of constant folding. Empty is
--- also returned for variables with no initialization expression.
-
-- Corresponding_Concurrent_Type (Node18)
-- Present in record types that are constructed by the expander to
-- represent task and protected types (Is_Concurrent_Record_Type flag
-- Discriminant_Number (Uint15)
-- Present in discriminants. Gives the ranking of a discriminant in
-- the list of discriminants of the type, i.e. a sequential integer
--- index starting at 1 and ranging up to Number_Discriminants.
+-- index starting at 1 and ranging up to number of discriminants.
-- Dispatch_Table_Wrappers (Elist26) [implementation base type only]
-- Present in library level record type entities if we are generating
-- code, then if there is no other elaboration code, obviously there
-- is no need to set the flag.
--- Enclosing_Dynamic_Scope (synthesized)
--- Applies to all entities. Returns the closest dynamic scope in which
--- the entity is declared or Standard_Standard for library-level entities
-
-- Enclosing_Scope (Node18)
-- Present in labels. Denotes the innermost enclosing construct that
-- contains the label. Identical to the scope of the label, except for
-- Similar to First_Component, but discriminants are not skipped, so will
-- find the first discriminant if discriminants are present.
--- First_Discriminant (synthesized)
--- Applies to types with discriminants. The discriminants are the first
--- entities declared in the type, so normally this is equivalent to
--- First_Entity. The exception arises for tagged types, where the tag
--- itself is prepended to the front of the entity chain, so the
--- First_Discriminant function steps past the tag if it is present.
-
-- First_Entity (Node17)
-- Present in all entities which act as scopes to which a list of
-- associated entities is attached (blocks, class subtypes and types,
-- Note in particular that size clauses are present only for this
-- purpose, and should only be accessed if Has_Size_Clause is set.
--- First_Stored_Discriminant (synthesized)
--- Applies to types with discriminants. Gives the first discriminant
--- stored in the object. In many cases, these are the same as the
--- normal visible discriminants for the type, but in the case of
--- renamed discriminants, this is not always the case.
---
--- For tagged types, and untagged types which are root types or
--- derived types but which do not rename discriminants in their
--- root type, the stored discriminants are the same as the actual
--- discriminants of the type, and hence this function is the same
--- as First_Discriminant.
---
--- For derived non-tagged types that rename discriminants in the root
--- type this is the first of the discriminants that occur in the
--- root type. To be precise, in this case stored discriminants are
--- entities attached to the entity chain of the derived type which
--- are a copy of the discriminants of the root type. Furthermore their
--- Is_Completely_Hidden flag is set since although they are actually
--- stored in the object, they are not in the set of discriminants that
--- is visble in the type.
---
--- For derived untagged types, stored discriminants are the real
--- discriminants from Gigi's standpoint, i.e. those that will be
--- stored in actual objects of the type.
-
--- First_Subtype (synthesized)
--- Applies to all types and subtypes. For types, yields the first subtype
--- of the type. For subtypes, yields the first subtype of the base type
--- of the subtype.
-
--- First_Tag_Component (synthesized)
--- Applies to tagged record types, returns the entity for the first
--- _Tag field in this record.
-
-- Freeze_Node (Node7)
-- Present in all entities. If there is an associated freeze node for
-- the entity, this field references this freeze node. If no freeze
-- Applies to all entities, true for boolean types and subtypes,
-- i.e. Standard.Boolean and all types ultimately derived from it.
--- Is_By_Copy_Type (synthesized)
--- Applies to all type entities. Returns true if the entity is
--- a by copy type (RM 6.2(3)).
-
--- Is_By_Reference_Type (synthesized)
--- Applies to all type entities. True if the type is required to
--- be passed by reference, as defined in (RM 6.2(4-9)).
-
-- Is_Called (Flag102)
-- Present in subprograms. Returns true if the subprogram is called
-- in the unit being compiled or in a unit in the context. Used for
-- Applies to all type entities, true for decimal fixed point
-- types and subtypes.
--- Is_Derived_Type (synthesized)
--- Applies to all entities. Determine if given entity is a derived type.
--- Always false if argument is not a type.
-
-- Is_Descendent_Of_Address (Flag223)
-- Present in all type and subtype entities. Indicates that a type is an
-- address type that is visibly a numeric type. Used for semantic checks
-- Is_Incomplete_Type (synthesized)
-- Applies to all entities, true for incomplete types and subtypes
--- Is_Indefinite_Subtype (synthesized)
--- Applies to all entities for types and subtypes. Determines if given
--- entity is an unconstrained array type or subtype, a discriminated
--- record type or subtype with no initial discriminant values or a
--- class wide type or subtype.
-
-- Is_Inlined (Flag11)
-- Present in all entities. Set for functions and procedures which are
-- to be inlined. For subprograms created during expansion, this flag
-- record is declared to be limited. Note that this flag is not set
-- simply because some components of the record are limited.
--- Is_Limited_Type (synthesized)
--- Applies to all entities. True if entity is a limited type (limited
--- private type, limited interface type, task type, protected type,
--- composite containing a limited component, or a subtype of any of
--- these types).
-
-- Is_Local_Anonymous_Access (Flag194)
-- Present in access types. Set for an anonymous access type to indicate
-- that the type is created for a record component with an access
-- renaming is handled by the front end, by macro substitution of
-- a copy of the (evaluated) name tree whereever the variable is used.
--- Is_Inherently_Limited_Type (synthesized)
--- Applies to all type entities. True if the type is "inherently"
--- limited (i.e. cannot become nonlimited). From the Ada 2005
--- RM-7.5(8.1/2), "a type with a part that is of a task, protected, or
--- explicitly limited record type". These are the types that are defined
--- as return-by-reference types in Ada 95 (see RM95-6.5(11-16)). In Ada
--- 2005, these are the types that require build-in-place for function
--- calls. Note that build-in-place is allowed for other types, too.
-
-- Is_Return_Object (Flag209)
-- Present in all object entities. True if the object is the return
-- object of an extended_return_statement; False otherwise.
-- Empty if applied to the last literal. This is actually a synonym
-- for Next, but its use is preferred in this context.
--- Next_Tag_Component (synthesized)
--- Applies to components of tagged record types. Given a _Tag field
--- of a record, returns the next _Tag field in this record.
-
-- Non_Binary_Modulus (Flag58) [base type only]
-- Present in all subtype and type entities. Set for modular integer
-- types if the modulus value is other than a power of 2.
-- Applies to array types and subtypes. Returns the number of dimensions
-- of the array type or subtype as a value of type Pos.
--- Number_Discriminants (synthesized)
--- Applies to all types with discriminants. Yields the number of
--- discriminants as a value of type Pos.
-
-- Number_Entries (synthesized)
-- Applies to concurrent types. Returns the number of entries that are
-- declared within the task or protected definition for the type.
-- Was_Hidden (Flag196)
-- Declaration_Node (synth)
- -- Enclosing_Dynamic_Scope (synth)
-- Has_Foreign_Convention (synth)
- -- Is_Derived_Type (synth)
-- Is_Dynamic_Scope (synth)
- -- Is_Limited_Type (synth)
-- Is_Standard_Character_Type (synth)
-- Underlying_Type (synth)
-- all classification attributes (synth)
-- Universal_Aliasing (Flag216) (base type only)
-- Alignment_Clause (synth)
- -- Ancestor_Subtype (synth)
-- Base_Type (synth)
- -- First_Subtype (synth)
-- Has_Private_Ancestor (synth)
-- Implementation_Base_Type (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
- -- Is_By_Copy_Type (synth)
- -- Is_By_Reference_Type (synth)
- -- Is_Inherently_Limited_Type (synth)
-- Root_Type (synth)
-- Size_Clause (synth)
-- Storage_Size_Variable (Node15) (base type only)
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
- -- Associated_Storage_Pool (Node22) (base type only)
+ -- Associated_Storage_Pool (Node22) (root type only)
-- Associated_Final_Chain (Node23)
-- Has_Pragma_Controlled (Flag27) (base type only)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Last_Entity (Node20)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
- -- First_Discriminant (synth)
- -- (plus type attributes)
+ -- (plus type attributes)
-- E_Component
-- Normalized_First_Bit (Uint8)
-- Is_Return_Object (Flag209)
-- Next_Component (synth)
-- Next_Component_Or_Discriminant (synth)
- -- Next_Tag_Component (synth)
-- E_Constant
-- E_Loop_Parameter
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
- -- Constant_Value (synth)
-- Size_Clause (synth)
-- E_Decimal_Fixed_Point_Type
-- Machine_Radix_10 (Flag84)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
- -- (plus type attributes)
+ -- (plus type attributes)
-- E_Discriminant
-- Normalized_First_Bit (Uint8)
-- Nonzero_Is_True (Flag162) (base type only)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
- -- (plus type attributes)
+ -- (plus type attributes)
-- E_Exception
-- Esize (Uint12)
-- E_Exception_Type
-- Equivalent_Type (Node18)
- -- (plus type attributes)
+ -- (plus type attributes)
-- E_Floating_Point_Type
-- E_Floating_Point_Subtype
-- Scalar_Range (Node20)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
- -- (plus type attributes)
+ -- (plus type attributes)
-- E_Function
-- E_Generic_Function
-- Storage_Size_Variable (Node15) (base type only)
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
- -- Associated_Storage_Pool (Node22) (base type only)
+ -- Associated_Storage_Pool (Node22) (root type only)
-- Associated_Final_Chain (Node23)
-- (plus type attributes)
-- Private_Dependents (Elist18)
-- Discriminant_Constraint (Elist21)
-- Stored_Constraint (Elist23)
- -- First_Discriminant (synth)
- -- First_Stored_Discriminant (synth)
-- (plus type attributes)
-- E_In_Parameter
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Has_Completion (Flag26)
- -- First_Discriminant (synth)
- -- First_Stored_Discriminant (synth)
-- (plus type attributes)
-- E_Loop
-- (plus type attributes)
-- E_Named_Integer
- -- Constant_Value (synth)
-- E_Named_Real
- -- Constant_Value (synth)
-- E_Operator
-- First_Entity (Node17)
-- Has_Small_Clause (Flag67)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
- -- (plus type attributes)
+ -- (plus type attributes)
-- E_Package
-- E_Generic_Package
-- Has_Completion (Flag26)
-- Is_Controlled (Flag42) (base type only)
-- Is_For_Access_Subtype (Flag118) (subtype only)
- -- First_Discriminant (synth)
- -- First_Stored_Discriminant (synth)
-- (plus type attributes)
-- E_Procedure
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
- -- First_Discriminant (synth)
- -- First_Stored_Discriminant (synth)
- -- First_Tag_Component (synth)
-- (plus type attributes)
-- E_Record_Type_With_Private
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
- -- First_Discriminant (synth)
- -- First_Stored_Discriminant (synth)
- -- First_Tag_Component (synth)
-- (plus type attributes)
-- E_Return_Statement
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
- -- Constant_Value (synth)
-- Size_Clause (synth)
-- E_Void
function Address_Clause (Id : E) return N;
function Alignment_Clause (Id : E) return N;
- function Ancestor_Subtype (Id : E) return E;
- function Available_View (Id : E) return E;
function Base_Type (Id : E) return E;
- function Constant_Value (Id : E) return N;
function Declaration_Node (Id : E) return N;
function Designated_Type (Id : E) return E;
- function Enclosing_Dynamic_Scope (Id : E) return E;
function First_Component (Id : E) return E;
function First_Component_Or_Discriminant (Id : E) return E;
- function First_Discriminant (Id : E) return E;
function First_Formal (Id : E) return E;
function First_Formal_With_Extras (Id : E) return E;
- function First_Stored_Discriminant (Id : E) return E;
- function First_Subtype (Id : E) return E;
function Has_Attach_Handler (Id : E) return B;
function Has_Entries (Id : E) return B;
function Has_Foreign_Convention (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
function Is_Boolean_Type (Id : E) return B;
- function Is_By_Copy_Type (Id : E) return B;
- function Is_By_Reference_Type (Id : E) return B;
function Is_Constant_Object (Id : E) return B;
- function Is_Derived_Type (Id : E) return B;
function Is_Discriminal (Id : E) return B;
function Is_Dynamic_Scope (Id : E) return B;
- function Is_Indefinite_Subtype (Id : E) return B;
- function Is_Limited_Type (Id : E) return B;
function Is_Package_Or_Generic_Package (Id : E) return B;
function Is_Prival (Id : E) return B;
function Is_Protected_Component (Id : E) return B;
function Is_Protected_Record_Type (Id : E) return B;
- function Is_Inherently_Limited_Type (Id : E) return B;
function Is_Standard_Character_Type (Id : E) return B;
function Is_String_Type (Id : E) return B;
function Is_Task_Record_Type (Id : E) return B;
function Next_Literal (Id : E) return E;
function Next_Stored_Discriminant (Id : E) return E;
function Number_Dimensions (Id : E) return Pos;
- function Number_Discriminants (Id : E) return Pos;
function Number_Entries (Id : E) return Nat;
function Number_Formals (Id : E) return Pos;
- function Parameter_Mode (Id : E) return Formal_Kind;
function Root_Type (Id : E) return E;
+ function Parameter_Mode (Id : E) return Formal_Kind;
function Scope_Depth_Set (Id : E) return B;
function Size_Clause (Id : E) return N;
function Stream_Size_Clause (Id : E) return N;
- function First_Tag_Component (Id : E) return E;
- function Next_Tag_Component (Id : E) return E;
function Type_High_Bound (Id : E) return N;
function Type_Low_Bound (Id : E) return N;
function Underlying_Type (Id : E) return E;
with Rtsfind; use Rtsfind;
with Ttypes; use Ttypes;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
+with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Stand; use Stand;
with Snames; use Snames;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch12; use Sem_Ch12;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch11; use Sem_Ch11;
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Nlists; use Nlists;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
with Sem_Res; use Sem_Res;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Nlists; use Nlists;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Lib; use Lib;
with Restrict; use Restrict;
with Rident; use Rident;
+with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
extern void Check_Elaboration_Code_Allowed (Node_Id);
extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id);
+/* sem_aux: */
+
+#define Ancestor_Subtype sem_aux__ancestor_subtype
+#define First_Discriminant sem_aux__first_discriminant
+#define First_Stored_Discriminant sem_aux__first_stored_discriminant
+#define First_Subtype sem_aux__first_subtype
+#define Is_By_Reference_Type sem_aux__is_by_reference_type
+#define Is_Derived_Type sem_aux__is_derived_type
+
+extern Entity_Id Ancestor_Subtype (Entity_Id);
+extern Entity_Id First_Discriminant (Entity_Id);
+extern Entity_Id First_Stored_Discriminant (Entity_Id);
+extern Entity_Id First_Subtype (Entity_Id);
+extern Boolean Is_By_Reference_Type (Entity_Id);
+extern Boolean Is_Derived_Type (Entity_Id);
+
/* sem_elim: */
#define Eliminate_Error_Msg sem_elim__eliminate_error_msg
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Opt; use Opt;
with Repinfo; use Repinfo;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch13; use Sem_Ch13;
with Rtsfind; use Rtsfind;
with Sdefault; use Sdefault;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
-- --
------------------------------------------------------------------------------
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Namet; use Namet;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+
package body Sem_Aux is
+ ----------------------
+ -- Ancestor_Subtype --
+ ----------------------
+
+ function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
+ begin
+ -- If this is first subtype, or is a base type, then there is no
+ -- ancestor subtype, so we return Empty to indicate this fact.
+
+ if Is_First_Subtype (Typ) or else Typ = Base_Type (Typ) then
+ return Empty;
+ end if;
+
+ declare
+ D : constant Node_Id := Declaration_Node (Typ);
+
+ begin
+ -- If we have a subtype declaration, get the ancestor subtype
+
+ if Nkind (D) = N_Subtype_Declaration then
+ if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
+ return Entity (Subtype_Mark (Subtype_Indication (D)));
+ else
+ return Entity (Subtype_Indication (D));
+ end if;
+
+ -- If not, then no subtype indication is available
+
+ else
+ return Empty;
+ end if;
+ end;
+ end Ancestor_Subtype;
+
+ --------------------
+ -- Available_View --
+ --------------------
+
+ function Available_View (Typ : Entity_Id) return Entity_Id is
+ begin
+ if Is_Incomplete_Type (Typ)
+ and then Present (Non_Limited_View (Typ))
+ then
+ -- The non-limited view may itself be an incomplete type, in which
+ -- case get its full view.
+
+ return Get_Full_View (Non_Limited_View (Typ));
+
+ elsif Is_Class_Wide_Type (Typ)
+ and then Is_Incomplete_Type (Etype (Typ))
+ and then Present (Non_Limited_View (Etype (Typ)))
+ then
+ return Class_Wide_Type (Non_Limited_View (Etype (Typ)));
+
+ else
+ return Typ;
+ end if;
+ end Available_View;
+
+ --------------------
+ -- Constant_Value --
+ --------------------
+
+ function Constant_Value (Ent : Entity_Id) return Node_Id is
+ D : constant Node_Id := Declaration_Node (Ent);
+ Full_D : Node_Id;
+
+ begin
+ -- If we have no declaration node, then return no constant value.
+ -- Not clear how this can happen, but it does sometimes and this is
+ -- the safest approach.
+
+ if No (D) then
+ return Empty;
+
+ -- Normal case where a declaration node is present
+
+ elsif Nkind (D) = N_Object_Renaming_Declaration then
+ return Renamed_Object (Ent);
+
+ -- If this is a component declaration whose entity is constant, it
+ -- is a prival within a protected function. It does not have
+ -- a constant value.
+
+ elsif Nkind (D) = N_Component_Declaration then
+ return Empty;
+
+ -- If there is an expression, return it
+
+ elsif Present (Expression (D)) then
+ return (Expression (D));
+
+ -- For a constant, see if we have a full view
+
+ elsif Ekind (Ent) = E_Constant
+ and then Present (Full_View (Ent))
+ then
+ Full_D := Parent (Full_View (Ent));
+
+ -- The full view may have been rewritten as an object renaming
+
+ if Nkind (Full_D) = N_Object_Renaming_Declaration then
+ return Name (Full_D);
+ else
+ return Expression (Full_D);
+ end if;
+
+ -- Otherwise we have no expression to return
+
+ else
+ return Empty;
+ end if;
+ end Constant_Value;
+
+ -----------------------------
+ -- Enclosing_Dynamic_Scope --
+ -----------------------------
+
+ function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
+ S : Entity_Id;
+
+ begin
+ -- The following test is an error defense against some syntax
+ -- errors that can leave scopes very messed up.
+
+ if Ent = Standard_Standard then
+ return Ent;
+ end if;
+
+ -- Normal case, search enclosing scopes
+
+ -- Note: the test for Present (S) should not be required, it is a
+ -- defence against an ill-formed tree.
+
+ S := Scope (Ent);
+ loop
+ -- If we somehow got an empty value for Scope, the tree must be
+ -- malformed. Rather than blow up we return Standard in this case.
+
+ if No (S) then
+ return Standard_Standard;
+
+ -- Quit if we get to standard or a dynamic scope
+
+ elsif S = Standard_Standard
+ or else Is_Dynamic_Scope (S)
+ then
+ return S;
+
+ -- Otherwise keep climbing
+
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+ end Enclosing_Dynamic_Scope;
+
+ ------------------------
+ -- First_Discriminant --
+ ------------------------
+
+ function First_Discriminant (Typ : Entity_Id) return Entity_Id is
+ Ent : Entity_Id;
+
+ begin
+ pragma Assert
+ (Has_Discriminants (Typ)
+ or else Has_Unknown_Discriminants (Typ));
+
+ Ent := First_Entity (Typ);
+
+ -- The discriminants are not necessarily contiguous, because access
+ -- discriminants will generate itypes. They are not the first entities
+ -- either, because tag and controller record must be ahead of them.
+
+ if Chars (Ent) = Name_uTag then
+ Ent := Next_Entity (Ent);
+ end if;
+
+ if Chars (Ent) = Name_uController then
+ Ent := Next_Entity (Ent);
+ end if;
+
+ -- Skip all hidden stored discriminants if any
+
+ while Present (Ent) loop
+ exit when Ekind (Ent) = E_Discriminant
+ and then not Is_Completely_Hidden (Ent);
+
+ Ent := Next_Entity (Ent);
+ end loop;
+
+ pragma Assert (Ekind (Ent) = E_Discriminant);
+
+ return Ent;
+ end First_Discriminant;
+
+ -------------------------------
+ -- First_Stored_Discriminant --
+ -------------------------------
+
+ function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
+ Ent : Entity_Id;
+
+ function Has_Completely_Hidden_Discriminant
+ (Typ : Entity_Id) return Boolean;
+ -- Scans the Discriminants to see whether any are Completely_Hidden
+ -- (the mechanism for describing non-specified stored discriminants)
+
+ ----------------------------------------
+ -- Has_Completely_Hidden_Discriminant --
+ ----------------------------------------
+
+ function Has_Completely_Hidden_Discriminant
+ (Typ : Entity_Id) return Boolean
+ is
+ Ent : Entity_Id;
+
+ begin
+ pragma Assert (Ekind (Typ) = E_Discriminant);
+
+ Ent := Typ;
+ while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
+ if Is_Completely_Hidden (Ent) then
+ return True;
+ end if;
+
+ Ent := Next_Entity (Ent);
+ end loop;
+
+ return False;
+ end Has_Completely_Hidden_Discriminant;
+
+ -- Start of processing for First_Stored_Discriminant
+
+ begin
+ pragma Assert
+ (Has_Discriminants (Typ)
+ or else Has_Unknown_Discriminants (Typ));
+
+ Ent := First_Entity (Typ);
+
+ if Chars (Ent) = Name_uTag then
+ Ent := Next_Entity (Ent);
+ end if;
+
+ if Chars (Ent) = Name_uController then
+ Ent := Next_Entity (Ent);
+ end if;
+
+ if Has_Completely_Hidden_Discriminant (Ent) then
+
+ while Present (Ent) loop
+ exit when Is_Completely_Hidden (Ent);
+ Ent := Next_Entity (Ent);
+ end loop;
+
+ end if;
+
+ pragma Assert (Ekind (Ent) = E_Discriminant);
+
+ return Ent;
+ end First_Stored_Discriminant;
+
+ -------------------
+ -- First_Subtype --
+ -------------------
+
+ function First_Subtype (Typ : Entity_Id) return Entity_Id is
+ B : constant Entity_Id := Base_Type (Typ);
+ F : constant Node_Id := Freeze_Node (B);
+ Ent : Entity_Id;
+
+ begin
+ -- If the base type has no freeze node, it is a type in standard,
+ -- and always acts as its own first subtype unless it is one of
+ -- the predefined integer types. If the type is formal, it is also
+ -- a first subtype, and its base type has no freeze node. On the other
+ -- hand, a subtype of a generic formal is not its own first_subtype.
+ -- Its base type, if anonymous, is attached to the formal type decl.
+ -- from which the first subtype is obtained.
+
+ if No (F) then
+
+ if B = Base_Type (Standard_Integer) then
+ return Standard_Integer;
+
+ elsif B = Base_Type (Standard_Long_Integer) then
+ return Standard_Long_Integer;
+
+ elsif B = Base_Type (Standard_Short_Short_Integer) then
+ return Standard_Short_Short_Integer;
+
+ elsif B = Base_Type (Standard_Short_Integer) then
+ return Standard_Short_Integer;
+
+ elsif B = Base_Type (Standard_Long_Long_Integer) then
+ return Standard_Long_Long_Integer;
+
+ elsif Is_Generic_Type (Typ) then
+ if Present (Parent (B)) then
+ return Defining_Identifier (Parent (B));
+ else
+ return Defining_Identifier (Associated_Node_For_Itype (B));
+ end if;
+
+ else
+ return B;
+ end if;
+
+ -- Otherwise we check the freeze node, if it has a First_Subtype_Link
+ -- then we use that link, otherwise (happens with some Itypes), we use
+ -- the base type itself.
+
+ else
+ Ent := First_Subtype_Link (F);
+
+ if Present (Ent) then
+ return Ent;
+ else
+ return B;
+ end if;
+ end if;
+ end First_Subtype;
+
+ -------------------------
+ -- First_Tag_Component --
+ -------------------------
+
+ function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
+ Comp : Entity_Id;
+ Ctyp : Entity_Id;
+
+ begin
+ Ctyp := Typ;
+ pragma Assert (Is_Tagged_Type (Ctyp));
+
+ if Is_Class_Wide_Type (Ctyp) then
+ Ctyp := Root_Type (Ctyp);
+ end if;
+
+ if Is_Private_Type (Ctyp) then
+ Ctyp := Underlying_Type (Ctyp);
+
+ -- If the underlying type is missing then the source program has
+ -- errors and there is nothing else to do (the full-type declaration
+ -- associated with the private type declaration is missing).
+
+ if No (Ctyp) then
+ return Empty;
+ end if;
+ end if;
+
+ Comp := First_Entity (Ctyp);
+ while Present (Comp) loop
+ if Is_Tag (Comp) then
+ return Comp;
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ -- No tag component found
+
+ return Empty;
+ end First_Tag_Component;
+
----------------
-- Initialize --
----------------
Obsolescent_Warnings.Init;
end Initialize;
+ ---------------------
+ -- Is_By_Copy_Type --
+ ---------------------
+
+ function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
+ begin
+ -- If Id is a private type whose full declaration has not been seen,
+ -- we assume for now that it is not a By_Copy type. Clearly this
+ -- attribute should not be used before the type is frozen, but it is
+ -- needed to build the associated record of a protected type. Another
+ -- place where some lookahead for a full view is needed ???
+
+ return
+ Is_Elementary_Type (Ent)
+ or else (Is_Private_Type (Ent)
+ and then Present (Underlying_Type (Ent))
+ and then Is_Elementary_Type (Underlying_Type (Ent)));
+ end Is_By_Copy_Type;
+
+ --------------------------
+ -- Is_By_Reference_Type --
+ --------------------------
+
+ function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
+ Btype : constant Entity_Id := Base_Type (Ent);
+
+ begin
+ if Error_Posted (Ent)
+ or else Error_Posted (Btype)
+ then
+ return False;
+
+ elsif Is_Private_Type (Btype) then
+ declare
+ Utyp : constant Entity_Id := Underlying_Type (Btype);
+ begin
+ if No (Utyp) then
+ return False;
+ else
+ return Is_By_Reference_Type (Utyp);
+ end if;
+ end;
+
+ elsif Is_Incomplete_Type (Btype) then
+ declare
+ Ftyp : constant Entity_Id := Full_View (Btype);
+ begin
+ if No (Ftyp) then
+ return False;
+ else
+ return Is_By_Reference_Type (Ftyp);
+ end if;
+ end;
+
+ elsif Is_Concurrent_Type (Btype) then
+ return True;
+
+ elsif Is_Record_Type (Btype) then
+ if Is_Limited_Record (Btype)
+ or else Is_Tagged_Type (Btype)
+ or else Is_Volatile (Btype)
+ then
+ return True;
+
+ else
+ declare
+ C : Entity_Id;
+
+ begin
+ C := First_Component (Btype);
+ while Present (C) loop
+ if Is_By_Reference_Type (Etype (C))
+ or else Is_Volatile (Etype (C))
+ then
+ return True;
+ end if;
+
+ C := Next_Component (C);
+ end loop;
+ end;
+
+ return False;
+ end if;
+
+ elsif Is_Array_Type (Btype) then
+ return
+ Is_Volatile (Btype)
+ or else Is_By_Reference_Type (Component_Type (Btype))
+ or else Is_Volatile (Component_Type (Btype))
+ or else Has_Volatile_Components (Btype);
+
+ else
+ return False;
+ end if;
+ end Is_By_Reference_Type;
+
+ ---------------------
+ -- Is_Derived_Type --
+ ---------------------
+
+ function Is_Derived_Type (Ent : E) return B is
+ Par : Node_Id;
+
+ begin
+ if Is_Type (Ent)
+ and then Base_Type (Ent) /= Root_Type (Ent)
+ and then not Is_Class_Wide_Type (Ent)
+ then
+ if not Is_Numeric_Type (Root_Type (Ent)) then
+ return True;
+
+ else
+ Par := Parent (First_Subtype (Ent));
+
+ return Present (Par)
+ and then Nkind (Par) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Par)) =
+ N_Derived_Type_Definition;
+ end if;
+
+ else
+ return False;
+ end if;
+ end Is_Derived_Type;
+
+ ---------------------------
+ -- Is_Indefinite_Subtype --
+ ---------------------------
+
+ function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
+ K : constant Entity_Kind := Ekind (Ent);
+
+ begin
+ if Is_Constrained (Ent) then
+ return False;
+
+ elsif K in Array_Kind
+ or else K in Class_Wide_Kind
+ or else Has_Unknown_Discriminants (Ent)
+ then
+ return True;
+
+ -- Known discriminants: indefinite if there are no default values
+
+ elsif K in Record_Kind
+ or else Is_Incomplete_Or_Private_Type (Ent)
+ or else Is_Concurrent_Type (Ent)
+ then
+ return (Has_Discriminants (Ent)
+ and then
+ No (Discriminant_Default_Value (First_Discriminant (Ent))));
+
+ else
+ return False;
+ end if;
+ end Is_Indefinite_Subtype;
+
+ --------------------------------
+ -- Is_Inherently_Limited_Type --
+ --------------------------------
+
+ function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is
+ Btype : constant Entity_Id := Base_Type (Ent);
+
+ begin
+ if Is_Private_Type (Btype) then
+ declare
+ Utyp : constant Entity_Id := Underlying_Type (Btype);
+ begin
+ if No (Utyp) then
+ return False;
+ else
+ return Is_Inherently_Limited_Type (Utyp);
+ end if;
+ end;
+
+ elsif Is_Concurrent_Type (Btype) then
+ return True;
+
+ elsif Is_Record_Type (Btype) then
+ if Is_Limited_Record (Btype) then
+ return not Is_Interface (Btype)
+ or else Is_Protected_Interface (Btype)
+ or else Is_Synchronized_Interface (Btype)
+ or else Is_Task_Interface (Btype);
+
+ elsif Is_Class_Wide_Type (Btype) then
+ return Is_Inherently_Limited_Type (Root_Type (Btype));
+
+ else
+ declare
+ C : Entity_Id;
+
+ begin
+ C := First_Component (Btype);
+ while Present (C) loop
+ if Is_Inherently_Limited_Type (Etype (C)) then
+ return True;
+ end if;
+
+ C := Next_Component (C);
+ end loop;
+ end;
+
+ return False;
+ end if;
+
+ elsif Is_Array_Type (Btype) then
+ return Is_Inherently_Limited_Type (Component_Type (Btype));
+
+ else
+ return False;
+ end if;
+ end Is_Inherently_Limited_Type;
+
+ ---------------------
+ -- Is_Limited_Type --
+ ---------------------
+
+ function Is_Limited_Type (Ent : Entity_Id) return Boolean is
+ Btype : constant E := Base_Type (Ent);
+ Rtype : constant E := Root_Type (Btype);
+
+ begin
+ if not Is_Type (Ent) then
+ return False;
+
+ elsif Ekind (Btype) = E_Limited_Private_Type
+ or else Is_Limited_Composite (Btype)
+ then
+ return True;
+
+ elsif Is_Concurrent_Type (Btype) then
+ return True;
+
+ -- The Is_Limited_Record flag normally indicates that the type is
+ -- limited. The exception is that a type does not inherit limitedness
+ -- from its interface ancestor. So the type may be derived from a
+ -- limited interface, but is not limited.
+
+ elsif Is_Limited_Record (Ent)
+ and then not Is_Interface (Ent)
+ then
+ return True;
+
+ -- Otherwise we will look around to see if there is some other reason
+ -- for it to be limited, except that if an error was posted on the
+ -- entity, then just assume it is non-limited, because it can cause
+ -- trouble to recurse into a murky erroneous entity!
+
+ elsif Error_Posted (Ent) then
+ return False;
+
+ elsif Is_Record_Type (Btype) then
+
+ if Is_Limited_Interface (Ent) then
+ return True;
+
+ -- AI-419: limitedness is not inherited from a limited interface
+
+ elsif Is_Limited_Record (Rtype) then
+ return not Is_Interface (Rtype)
+ or else Is_Protected_Interface (Rtype)
+ or else Is_Synchronized_Interface (Rtype)
+ or else Is_Task_Interface (Rtype);
+
+ elsif Is_Class_Wide_Type (Btype) then
+ return Is_Limited_Type (Rtype);
+
+ else
+ declare
+ C : E;
+
+ begin
+ C := First_Component (Btype);
+ while Present (C) loop
+ if Is_Limited_Type (Etype (C)) then
+ return True;
+ end if;
+
+ C := Next_Component (C);
+ end loop;
+ end;
+
+ return False;
+ end if;
+
+ elsif Is_Array_Type (Btype) then
+ return Is_Limited_Type (Component_Type (Btype));
+
+ else
+ return False;
+ end if;
+ end Is_Limited_Type;
+
+ ------------------------
+ -- Next_Tag_Component --
+ ------------------------
+
+ function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
+ Comp : Entity_Id;
+
+ begin
+ pragma Assert (Is_Tag (Tag));
+
+ Comp := Next_Entity (Tag);
+ while Present (Comp) loop
+ if Is_Tag (Comp) then
+ pragma Assert (Chars (Comp) /= Name_uTag);
+ return Comp;
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ -- No tag component found
+
+ return Empty;
+ end Next_Tag_Component;
+
+ --------------------------
+ -- Number_Discriminants --
+ --------------------------
+
+ function Number_Discriminants (Typ : Entity_Id) return Pos is
+ N : Int;
+ Discr : Entity_Id;
+
+ begin
+ N := 0;
+ Discr := First_Discriminant (Typ);
+ while Present (Discr) loop
+ N := N + 1;
+ Discr := Next_Discriminant (Discr);
+ end loop;
+
+ return N;
+ end Number_Discriminants;
+
---------------
-- Tree_Read --
---------------
-- Package containing utility procedures used throughout the compiler,
-- and also by ASIS so dependencies are limited to ASIS included packages.
--- Note: contents are minimal for now, the intent is to move stuff from
--- Sem_Util that meets the ASIS dependency requirements, and also stuff
--- from Einfo, where Einfo had excessive semantic knowledge of the tree.
+-- Historical note. Many of the routines here were originally in Einfo, but
+-- Einfo is supposed to be a relatively low level package dealing with the
+-- content of entities in the tree, so this package is used for routines that
+-- require more than minimal semantic knowldge.
-with Alloc; use Alloc;
+with Alloc; use Alloc;
with Table;
-with Types; use Types;
+with Types; use Types;
package Sem_Aux is
Table_Increment => Alloc.Obsolescent_Warnings_Increment,
Table_Name => "Obsolescent_Warnings");
- -----------------
- -- Subprograms --
- -----------------
-
procedure Initialize;
-- Called at the start of compilation of each new main source file to
-- initialize the allocation of the Obsolescent_Warnings table. Note that
-- Initialize must not be called if Tree_Read is used.
procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines.
+ -- Initializes Obsolescent_Warnings table from current tree file using the
+ -- relevant Table.Tree_Read routine.
procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
+ -- Writes out Obsolescent_Warnings table to current tree file using the
+ -- relevant Table.Tree_Write routine.
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id;
+ -- The argument Id is a type or subtype entity. If the argument is a
+ -- subtype then it returns the subtype or type from which the subtype was
+ -- obtained, otherwise it returns Empty.
+
+ function Available_View (Typ : Entity_Id) return Entity_Id;
+ -- Typ is typically a type that has the With_Type flag set. Returns the
+ -- non-limited view of the type, if available, otherwise the type itself.
+ -- For class-wide types, there is no direct link in the tree, so we have
+ -- to retrieve the class-wide type of the non-limited view of the Etype.
+ -- Returns the argument unchanged if it is not one of these cases.
+
+ function Constant_Value (Ent : Entity_Id) return Node_Id;
+ -- Id is a variable, constant, named integer, or named real entity. This
+ -- call obtains the initialization expression for the entity. Will return
+ -- Empty for for a deferred constant whose full view is not available or
+ -- in some other cases of internal entities, which cannot be treated as
+ -- constants from the point of view of constant folding. Empty is also
+ -- returned for variables with no initialization expression.
+
+ function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
+ -- For any entity, Ent, returns the closest dynamic scope in which the
+ -- entity is declared or Standard_Standard for library-level entities
+
+ function First_Discriminant (Typ : Entity_Id) return Entity_Id;
+ -- Typ is a type with discriminants. The discriminants are the first
+ -- entities declared in the type, so normally this is equivalent to
+ -- First_Entity. The exception arises for tagged types, where the tag
+ -- itself is prepended to the front of the entity chain, so the
+ -- First_Discriminant function steps past the tag if it is present.
+
+ function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id;
+ -- Typ is a type with discriminants. Gives the first discriminant stored
+ -- in an object of this type. In many cases, these are the same as the
+ -- normal visible discriminants for the type, but in the case of renamed
+ -- discriminants, this is not always the case.
+ --
+ -- For tagged types, and untagged types which are root types or derived
+ -- types but which do not rename discriminants in their root type, the
+ -- stored discriminants are the same as the actual discriminants of the
+ -- type, and hence this function is the same as First_Discriminant.
+ --
+ -- For derived non-tagged types that rename discriminants in the root type
+ -- this is the first of the discriminants that occur in the root type. To
+ -- be precise, in this case stored discriminants are entities attached to
+ -- the entity chain of the derived type which are a copy of the
+ -- discriminants of the root type. Furthermore their Is_Completely_Hidden
+ -- flag is set since although they are actually stored in the object, they
+ -- are not in the set of discriminants that is visble in the type.
+ --
+ -- For derived untagged types, the set of stored discriminants are the real
+ -- discriminants from Gigi's standpoint, i.e. those that will be stored in
+ -- actual objects of the type.
+
+ function First_Subtype (Typ : Entity_Id) return Entity_Id;
+ -- Applies to all types and subtypes. For types, yields the first subtype
+ -- of the type. For subtypes, yields the first subtype of the base type of
+ -- the subtype.
+
+ function First_Tag_Component (Typ : Entity_Id) return Entity_Id;
+ -- Typ must be a tagged record type. This function returns the Entity for
+ -- the first _Tag field in the record type.
+
+ function Is_By_Copy_Type (Ent : Entity_Id) return Boolean;
+ -- Ent is any entity. Returns True if Ent is a type entity where the type
+ -- is required to be passed by copy, as defined in (RM 6.2(3)).
+
+ function Is_By_Reference_Type (Ent : Entity_Id) return Boolean;
+ -- Ent is any entity. Returns True if Ent is a type entity where the type
+ -- is required to be passed by reference, as defined in (RM 6.2(4-9)).
+
+ function Is_Derived_Type (Ent : Entity_Id) return Boolean;
+ -- Determines if the given entity Ent is a derived type. Result is always
+ -- false if argument is not a type.
+
+ function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean;
+ -- Ent is any entity. Determines if given entity is an unconstrained array
+ -- type or subtype, a discriminated record type or subtype with no initial
+ -- discriminant values or a class wide type or subtype and returns True if
+ -- so. False for other type entities, or any entities that are not types.
+
+ function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean;
+ -- Ent is any entity. True for a type that is "inherently" limited (i.e.
+ -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with
+ -- a part that is of a task, protected, or explicitly limited record type".
+ -- These are the types that are defined as return-by-reference types in Ada
+ -- 95 (see RM95-6.5(11-16)). In Ada 2005, these are the types that require
+ -- build-in-place for function calls. Note that build-in-place is allowed
+ -- for other types, too.
+
+ function Is_Limited_Type (Ent : Entity_Id) return Boolean;
+ -- Ent is any entity. Returns true if Ent is a limited type (limited
+ -- private type, limited interface type, task type, protected type,
+ -- composite containing a limited component, or a subtype of any of
+ -- these types).
+
+ function Next_Tag_Component (Tag : Entity_Id) return Entity_Id;
+ -- Tag must be an entity representing a _Tag field of a tagged record.
+ -- The result returned is the next _Tag field in this record, or Empty
+ -- if this is the last such field.
+
+ function Number_Discriminants (Typ : Entity_Id) return Pos;
+ -- Typ is a type with discriminants, yields number of discriminants in type
end Sem_Aux;
with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Case; use Sem_Case;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Output; use Output;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
with Opt; use Opt;
with Output; use Output;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Eval; use Sem_Eval;
with Sem_Type; use Sem_Type;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Namet; use Namet;
with Nlists; use Nlists;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Aggr; use Sem_Aggr;
with Sem_Attr; use Sem_Attr;
with Sem_Cat; use Sem_Cat;
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Namet; use Namet;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Namet; use Namet;
+with Sem_Aux; use Sem_Aux;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
package body Sem_Smem is
with Opt; use Opt;
with Output; use Output;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch12; use Sem_Ch12;
with Scans; use Scans;
with Scn; use Scn;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
+with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
OSDN Git Service
