+2010-10-22 Robert Dewar <dewar@adacore.com>
+
+ * einfo.ads, einfo.adb (Has_Predicates): Flag is now on all entities
+ (simplifies code).
+ * exp_ch13.adb (Build_Predicate_Function): Output info msgs for
+ inheritance.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Make sure we have a
+ freeze node for entities for which a predicate is specified.
+ (Analyze_Aspect_Specifications): Avoid duplicate calls
+ * sem_ch3.adb (Analyze_Full_Type_Declaration): Remove attempt to avoid
+ duplicate calls to Analye_Aspect_Specifications.
+
+2010-10-22 Thomas Quinot <quinot@adacore.com>
+
+ * a-exextr.adb, atree.ads, freeze.adb: Minor reformatting.
+
2010-10-21 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb: Minor reformatting.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
pragma Export
(Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
- procedure Last_Chance_Handler
- (Except : Exception_Occurrence);
+ procedure Last_Chance_Handler (Except : Exception_Occurrence);
pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler");
pragma No_Return (Last_Chance_Handler);
-- Users can replace the default version of this routine,
function Parent (N : Node_Id) return Node_Id;
pragma Inline (Parent);
- -- Returns the parent of a node if the node is not a list member, or
- -- else the parent of the list containing the node if the node is a
- -- list member.
+ -- Returns the parent of a node if the node is not a list member, or else
+ -- the parent of the list containing the node if the node is a list member.
function No (N : Node_Id) return Boolean;
pragma Inline (No);
function Has_Predicates (Id : E) return B is
begin
- pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
return Flag250 (Id);
end Has_Predicates;
procedure Set_Has_Predicates (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id)
- or else Ekind (Id) = E_Function
- or else Ekind (Id) = E_Void);
Set_Flag250 (Id, V);
end Set_Has_Predicates;
-- such an object and no warning is generated.
-- Has_Predicates (Flag250)
--- Present in type and subtype entities and in subprogram entities. Set
--- if a pragma Predicate or Predicate aspect applies to the type, or if
--- it inherits a Predicate aspect from its parent or progenitor types.
--- Also set in the predicate function entity, to distinguish it among
--- entries in the Subprograms_For_Type.
+-- Present in all entities. Set in type and subtype entities if a pragma
+-- Predicate or Predicate aspect applies to the type, or if it inherits a
+-- Predicate aspect from its parent or progenitor types. Also set in the
+-- predicate function entity, to distinguish it among entries in the
+-- Subprograms_For_Type.
-- Has_Primitive_Operations (Flag120) [base type only]
-- Present in all type entities. Set if at least one primitive operation
-- Has_Pragma_Thread_Local_Storage (Flag169)
-- Has_Pragma_Unmodified (Flag233)
-- Has_Pragma_Unreferenced (Flag180)
+ -- Has_Predicates (Flag250)
-- Has_Private_Declaration (Flag155)
-- Has_Qualified_Name (Flag161)
-- Has_Stream_Size_Clause (Flag184)
-- Has_Object_Size_Clause (Flag172)
-- Has_Pragma_Preelab_Init (Flag221)
-- Has_Pragma_Unreferenced_Objects (Flag212)
- -- Has_Predicates (Flag250)
-- Has_Primitive_Operations (Flag120) (base type only)
-- Has_Size_Clause (Flag29)
-- Has_Specified_Layout (Flag100) (base type only)
-- Has_Missing_Return (Flag142)
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Postconditions (Flag240)
- -- Has_Predicates (Flag250)
-- Has_Recursive_Call (Flag143)
-- Has_Subprogram_Descriptor (Flag93)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Subprograms_For_Type (Node29)
-- Has_Invariants (Flag232)
-- Has_Postconditions (Flag240)
- -- Has_Predicates (Flag250)
-- Is_Machine_Code_Subprogram (Flag137)
-- Is_Pure (Flag44)
-- Is_Intrinsic_Subprogram (Flag64)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Postconditions (Flag240)
- -- Has_Predicates (Flag250)
-- Has_Subprogram_Descriptor (Flag93)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Asynchronous (Flag81)
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
+with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Imgv; use Exp_Imgv;
begin
if Present (T) and then Present (Predicate_Function (T)) then
+
+ -- Build the call to the predicate function of T
+
Exp :=
Make_Predicate_Call
(T,
Convert_To (T,
Make_Identifier (Loc, Chars => Object_Name)));
+ -- Add call to evolving expression, using AND THEN if needed
+
if No (Expr) then
Expr := Exp;
else
Left_Opnd => Relocate_Node (Expr),
Right_Opnd => Exp);
end if;
+
+ -- Output info message on inheritance if required
+
+ if Opt.List_Inherited_Aspects then
+ Error_Msg_Sloc := Sloc (Predicate_Function (T));
+ Error_Msg_Node_2 := T;
+ Error_Msg_N ("?info: & inherits predicate from & at #", Typ);
+ end if;
end if;
end Add_Call;
Arg1 := Get_Pragma_Arg (Arg1);
Arg2 := Get_Pragma_Arg (Arg2);
- -- We need to replace any occurrences of the name of the type
- -- with references to the object. We do this by first doing a
- -- preanalysis, to identify all the entities, then we traverse
- -- looking for the type entity, doing the needed substitution.
- -- The preanalysis is done with the special OK_To_Reference
- -- flag set on the type, so that if we get an occurrence of
- -- this type, it will be recognized as legitimate.
-
- Set_OK_To_Reference (Typ, True);
- Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
- Set_OK_To_Reference (Typ, False);
- Replace_Type (Arg2);
-
-- See if this predicate pragma is for the current type
if Entity (Arg1) = Typ then
- -- We have a match, add the expression
+ -- We have a match, this entry is for our subtype
+
+ -- First We need to replace any occurrences of the name of
+ -- the type with references to the object. We do this by
+ -- first doing a preanalysis, to identify all the entities,
+ -- then we traverse looking for the type entity, doing the
+ -- needed substitution. The preanalysis is done with the
+ -- special OK_To_Reference flag set on the type, so that if
+ -- we get an occurrence of this type, it will be recognized
+ -- as legitimate.
+
+ Set_OK_To_Reference (Typ, True);
+ Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
+ Set_OK_To_Reference (Typ, False);
+ Replace_Type (Arg2);
+
+ -- OK, replacement complete, now we can add the expression
if No (Expr) then
Expr := Relocate_Node (Arg2);
end;
end if;
- -- If any of the index types was an enumeration type with
- -- a non-standard rep clause, then we indicate that the
- -- array type is always packed (even if it is not bit packed).
+ -- If any of the index types was an enumeration type with a
+ -- non-standard rep clause, then we indicate that the array
+ -- type is always packed (even if it is not bit packed).
if Non_Standard_Enum then
Set_Has_Non_Standard_Rep (Base_Type (E));
-- Set True if delay is required
begin
+ -- Return if no aspects
+
if L = No_List then
return;
end if;
+ -- Return if already analyzed (avoids duplicate calls in some cases
+ -- where type declarations get rewritten and proessed twice).
+
+ if Analyzed (N) then
+ return;
+ end if;
+
+ -- Loop through apsects
+
Aspect := First (L);
while Present (Aspect) loop
declare
Set_From_Aspect_Specification (Aitem, True);
+ -- Make sure we have a freeze node (it might otherwise be
+ -- missing in cases like subtype X is Y, and we would not
+ -- have a place to build the predicate function).
+
+ Ensure_Freeze_Node (E);
+
-- For Predicate case, insert immediately after the entity
-- declaration. We do not have to worry about delay issues
-- since the pragma processing takes care of this.
Set_Optimize_Alignment_Flags (Def_Id);
Check_Eliminated (Def_Id);
- if Nkind (N) = N_Full_Type_Declaration then
- Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
- end if;
+ Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
end Analyze_Full_Type_Declaration;
----------------------------------
Set_Optimize_Alignment_Flags (Id);
Check_Eliminated (Id);
- <<Leave>>
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+ <<Leave>>
+ Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
end Analyze_Subtype_Declaration;
--------------------------------
projects / gcc.git / commitdiff