+ Alignment_Check_For_Esize_Change (U_Ent);
+
+ -- For objects, set Esize only
+
+ else
+ if Is_Elementary_Type (Etyp) then
+ if Size /= System_Storage_Unit
+ and then
+ Size /= System_Storage_Unit * 2
+ and then
+ Size /= System_Storage_Unit * 4
+ and then
+ Size /= System_Storage_Unit * 8
+ then
+ Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
+ Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
+ Error_Msg_N
+ ("size for primitive object must be a power of 2"
+ & " in the range ^-^", N);
+ end if;
+ end if;
+
+ Set_Esize (U_Ent, Size);
+ end if;
+
+ Set_Has_Size_Clause (U_Ent);
+ end if;
+ end Size;
+
+ -----------
+ -- Small --
+ -----------
+
+ -- Small attribute definition clause
+
+ when Attribute_Small => Small : declare
+ Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
+ Small : Ureal;
+
+ begin
+ Analyze_And_Resolve (Expr, Any_Real);
+
+ if Etype (Expr) = Any_Type then
+ return;
+
+ elsif not Is_Static_Expression (Expr) then
+ Flag_Non_Static_Expr
+ ("small requires static expression!", Expr);
+ return;
+
+ else
+ Small := Expr_Value_R (Expr);
+
+ if Small <= Ureal_0 then
+ Error_Msg_N ("small value must be greater than zero", Expr);
+ return;
+ end if;
+
+ end if;
+
+ if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
+ Error_Msg_N
+ ("small requires an ordinary fixed point type", Nam);
+
+ elsif Has_Small_Clause (U_Ent) then
+ Error_Msg_N ("small already given for &", Nam);
+
+ elsif Small > Delta_Value (U_Ent) then
+ Error_Msg_N
+ ("small value must not be greater then delta value", Nam);
+
+ else
+ Set_Small_Value (U_Ent, Small);
+ Set_Small_Value (Implicit_Base, Small);
+ Set_Has_Small_Clause (U_Ent);
+ Set_Has_Small_Clause (Implicit_Base);
+ Set_Has_Non_Standard_Rep (Implicit_Base);
+ end if;
+ end Small;
+
+ ------------------
+ -- Storage_Pool --
+ ------------------
+
+ -- Storage_Pool attribute definition clause
+
+ when Attribute_Storage_Pool => Storage_Pool : declare
+ Pool : Entity_Id;
+ T : Entity_Id;
+
+ begin
+ if Ekind (U_Ent) = E_Access_Subprogram_Type then
+ Error_Msg_N
+ ("storage pool cannot be given for access-to-subprogram type",
+ Nam);
+ return;
+
+ elsif not
+ Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
+ then
+ Error_Msg_N
+ ("storage pool can only be given for access types", Nam);
+ return;
+
+ elsif Is_Derived_Type (U_Ent) then
+ Error_Msg_N
+ ("storage pool cannot be given for a derived access type",
+ Nam);
+
+ elsif Duplicate_Clause then
+ return;
+
+ elsif Present (Associated_Storage_Pool (U_Ent)) then
+ Error_Msg_N ("storage pool already given for &", Nam);
+ return;
+ end if;
+
+ Analyze_And_Resolve
+ (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+ if not Denotes_Variable (Expr) then
+ Error_Msg_N ("storage pool must be a variable", Expr);
+ return;
+ end if;
+
+ if Nkind (Expr) = N_Type_Conversion then
+ T := Etype (Expression (Expr));
+ else
+ T := Etype (Expr);
+ end if;
+
+ -- The Stack_Bounded_Pool is used internally for implementing
+ -- access types with a Storage_Size. Since it only work
+ -- properly when used on one specific type, we need to check
+ -- that it is not hijacked improperly:
+ -- type T is access Integer;
+ -- for T'Storage_Size use n;
+ -- type Q is access Float;
+ -- for Q'Storage_Size use T'Storage_Size; -- incorrect
+
+ if RTE_Available (RE_Stack_Bounded_Pool)
+ and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool)
+ then
+ Error_Msg_N ("non-shareable internal Pool", Expr);
+ return;
+ end if;
+
+ -- If the argument is a name that is not an entity name, then
+ -- we construct a renaming operation to define an entity of
+ -- type storage pool.
+
+ if not Is_Entity_Name (Expr)
+ and then Is_Object_Reference (Expr)
+ then
+ Pool := Make_Temporary (Loc, 'P', Expr);
+
+ declare
+ Rnode : constant Node_Id :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pool,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Expr), Loc),
+ Name => Expr);
+
+ begin
+ Insert_Before (N, Rnode);
+ Analyze (Rnode);
+ Set_Associated_Storage_Pool (U_Ent, Pool);
+ end;
+
+ elsif Is_Entity_Name (Expr) then
+ Pool := Entity (Expr);
+
+ -- If pool is a renamed object, get original one. This can
+ -- happen with an explicit renaming, and within instances.
+
+ while Present (Renamed_Object (Pool))
+ and then Is_Entity_Name (Renamed_Object (Pool))
+ loop
+ Pool := Entity (Renamed_Object (Pool));
+ end loop;
+
+ if Present (Renamed_Object (Pool))
+ and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
+ and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
+ then
+ Pool := Entity (Expression (Renamed_Object (Pool)));
+ end if;
+
+ Set_Associated_Storage_Pool (U_Ent, Pool);
+
+ elsif Nkind (Expr) = N_Type_Conversion
+ and then Is_Entity_Name (Expression (Expr))
+ and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
+ then
+ Pool := Entity (Expression (Expr));
+ Set_Associated_Storage_Pool (U_Ent, Pool);
+
+ else
+ Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
+ return;
+ end if;
+ end Storage_Pool;
+
+ ------------------
+ -- Storage_Size --
+ ------------------
+
+ -- Storage_Size attribute definition clause
+
+ when Attribute_Storage_Size => Storage_Size : declare
+ Btype : constant Entity_Id := Base_Type (U_Ent);
+ Sprag : Node_Id;
+
+ begin
+ if Is_Task_Type (U_Ent) then
+ Check_Restriction (No_Obsolescent_Features, N);
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("storage size clause for task is an " &
+ "obsolescent feature (RM J.9)?", N);
+ Error_Msg_N ("\use Storage_Size pragma instead?", N);
+ end if;
+
+ FOnly := True;
+ end if;
+
+ if not Is_Access_Type (U_Ent)
+ and then Ekind (U_Ent) /= E_Task_Type
+ then
+ Error_Msg_N ("storage size cannot be given for &", Nam);
+
+ elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
+ Error_Msg_N
+ ("storage size cannot be given for a derived access type",
+ Nam);
+
+ elsif Duplicate_Clause then
+ null;
+
+ else
+ Analyze_And_Resolve (Expr, Any_Integer);
+
+ if Is_Access_Type (U_Ent) then
+ if Present (Associated_Storage_Pool (U_Ent)) then
+ Error_Msg_N ("storage pool already given for &", Nam);
+ return;
+ end if;
+
+ if Is_OK_Static_Expression (Expr)
+ and then Expr_Value (Expr) = 0
+ then
+ Set_No_Pool_Assigned (Btype);
+ end if;
+
+ else -- Is_Task_Type (U_Ent)
+ Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
+
+ if Present (Sprag) then
+ Error_Msg_Sloc := Sloc (Sprag);
+ Error_Msg_N
+ ("Storage_Size already specified#", Nam);
+ return;
+ end if;
+ end if;
+
+ Set_Has_Storage_Size_Clause (Btype);
+ end if;
+ end Storage_Size;
+
+ -----------------
+ -- Stream_Size --
+ -----------------
+
+ when Attribute_Stream_Size => Stream_Size : declare
+ Size : constant Uint := Static_Integer (Expr);
+
+ begin
+ if Ada_Version <= Ada_95 then
+ Check_Restriction (No_Implementation_Attributes, N);
+ end if;
+
+ if Duplicate_Clause then
+ null;
+
+ elsif Is_Elementary_Type (U_Ent) then
+ if Size /= System_Storage_Unit
+ and then
+ Size /= System_Storage_Unit * 2
+ and then
+ Size /= System_Storage_Unit * 4
+ and then
+ Size /= System_Storage_Unit * 8
+ then
+ Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
+ Error_Msg_N
+ ("stream size for elementary type must be a"
+ & " power of 2 and at least ^", N);
+
+ elsif RM_Size (U_Ent) > Size then
+ Error_Msg_Uint_1 := RM_Size (U_Ent);
+ Error_Msg_N
+ ("stream size for elementary type must be a"
+ & " power of 2 and at least ^", N);
+ end if;
+
+ Set_Has_Stream_Size_Clause (U_Ent);
+
+ else
+ Error_Msg_N ("Stream_Size cannot be given for &", Nam);
+ end if;
+ end Stream_Size;
+
+ ----------------
+ -- Value_Size --
+ ----------------
+
+ -- Value_Size attribute definition clause
+
+ when Attribute_Value_Size => Value_Size : declare
+ Size : constant Uint := Static_Integer (Expr);
+ Biased : Boolean;
+
+ begin
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("Value_Size cannot be given for &", Nam);
+
+ elsif Duplicate_Clause then
+ null;
+
+ elsif Is_Array_Type (U_Ent)
+ and then not Is_Constrained (U_Ent)
+ then
+ Error_Msg_N
+ ("Value_Size cannot be given for unconstrained array", Nam);
+
+ else
+ if Is_Elementary_Type (U_Ent) then
+ Check_Size (Expr, U_Ent, Size, Biased);
+ Set_Biased (U_Ent, N, "value size clause", Biased);
+ end if;
+
+ Set_RM_Size (U_Ent, Size);
+ end if;
+ end Value_Size;
+
+ -----------
+ -- Write --
+ -----------
+
+ when Attribute_Write =>
+ Analyze_Stream_TSS_Definition (TSS_Stream_Write);
+ Set_Has_Specified_Stream_Write (Ent);
+
+ -- All other attributes cannot be set
+
+ when others =>
+ Error_Msg_N
+ ("attribute& cannot be set with definition clause", N);
+ end case;
+
+ -- The test for the type being frozen must be performed after
+ -- any expression the clause has been analyzed since the expression
+ -- itself might cause freezing that makes the clause illegal.
+
+ if Rep_Item_Too_Late (U_Ent, N, FOnly) then
+ return;
+ end if;
+ end Analyze_Attribute_Definition_Clause;
+
+ ----------------------------
+ -- Analyze_Code_Statement --
+ ----------------------------
+
+ procedure Analyze_Code_Statement (N : Node_Id) is
+ HSS : constant Node_Id := Parent (N);
+ SBody : constant Node_Id := Parent (HSS);
+ Subp : constant Entity_Id := Current_Scope;
+ Stmt : Node_Id;
+ Decl : Node_Id;
+ StmtO : Node_Id;
+ DeclO : Node_Id;
+
+ begin
+ -- Analyze and check we get right type, note that this implements the
+ -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that
+ -- is the only way that Asm_Insn could possibly be visible.
+
+ Analyze_And_Resolve (Expression (N));
+
+ if Etype (Expression (N)) = Any_Type then
+ return;
+ elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
+ Error_Msg_N ("incorrect type for code statement", N);
+ return;
+ end if;
+
+ Check_Code_Statement (N);
+
+ -- Make sure we appear in the handled statement sequence of a
+ -- subprogram (RM 13.8(3)).
+
+ if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
+ or else Nkind (SBody) /= N_Subprogram_Body
+ then
+ Error_Msg_N
+ ("code statement can only appear in body of subprogram", N);
+ return;
+ end if;
+
+ -- Do remaining checks (RM 13.8(3)) if not already done
+
+ if not Is_Machine_Code_Subprogram (Subp) then
+ Set_Is_Machine_Code_Subprogram (Subp);
+
+ -- No exception handlers allowed
+
+ if Present (Exception_Handlers (HSS)) then
+ Error_Msg_N
+ ("exception handlers not permitted in machine code subprogram",
+ First (Exception_Handlers (HSS)));
+ end if;
+
+ -- No declarations other than use clauses and pragmas (we allow
+ -- certain internally generated declarations as well).
+
+ Decl := First (Declarations (SBody));
+ while Present (Decl) loop
+ DeclO := Original_Node (Decl);
+ if Comes_From_Source (DeclO)
+ and not Nkind_In (DeclO, N_Pragma,
+ N_Use_Package_Clause,
+ N_Use_Type_Clause,
+ N_Implicit_Label_Declaration)
+ then
+ Error_Msg_N
+ ("this declaration not allowed in machine code subprogram",
+ DeclO);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- No statements other than code statements, pragmas, and labels.
+ -- Again we allow certain internally generated statements.
+
+ Stmt := First (Statements (HSS));
+ while Present (Stmt) loop
+ StmtO := Original_Node (Stmt);
+ if Comes_From_Source (StmtO)
+ and then not Nkind_In (StmtO, N_Pragma,
+ N_Label,
+ N_Code_Statement)
+ then
+ Error_Msg_N
+ ("this statement is not allowed in machine code subprogram",
+ StmtO);
+ end if;
+
+ Next (Stmt);
+ end loop;
+ end if;
+ end Analyze_Code_Statement;
+
+ -----------------------------------------------
+ -- Analyze_Enumeration_Representation_Clause --
+ -----------------------------------------------
+
+ procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
+ Ident : constant Node_Id := Identifier (N);
+ Aggr : constant Node_Id := Array_Aggregate (N);
+ Enumtype : Entity_Id;
+ Elit : Entity_Id;
+ Expr : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Val : Uint;
+ Err : Boolean := False;
+
+ Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
+ Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
+ -- Allowed range of universal integer (= allowed range of enum lit vals)
+
+ Min : Uint;
+ Max : Uint;
+ -- Minimum and maximum values of entries
+
+ Max_Node : Node_Id;
+ -- Pointer to node for literal providing max value
+
+ begin
+ if Ignore_Rep_Clauses then
+ return;
+ end if;
+
+ -- First some basic error checks
+
+ Find_Type (Ident);
+ Enumtype := Entity (Ident);
+
+ if Enumtype = Any_Type
+ or else Rep_Item_Too_Early (Enumtype, N)
+ then
+ return;
+ else
+ Enumtype := Underlying_Type (Enumtype);
+ end if;
+
+ if not Is_Enumeration_Type (Enumtype) then
+ Error_Msg_NE
+ ("enumeration type required, found}",
+ Ident, First_Subtype (Enumtype));
+ return;
+ end if;
+
+ -- Ignore rep clause on generic actual type. This will already have
+ -- been flagged on the template as an error, and this is the safest
+ -- way to ensure we don't get a junk cascaded message in the instance.
+
+ if Is_Generic_Actual_Type (Enumtype) then
+ return;
+
+ -- Type must be in current scope
+
+ elsif Scope (Enumtype) /= Current_Scope then
+ Error_Msg_N ("type must be declared in this scope", Ident);
+ return;
+
+ -- Type must be a first subtype
+
+ elsif not Is_First_Subtype (Enumtype) then
+ Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
+ return;
+
+ -- Ignore duplicate rep clause
+
+ elsif Has_Enumeration_Rep_Clause (Enumtype) then
+ Error_Msg_N ("duplicate enumeration rep clause ignored", N);
+ return;
+
+ -- Don't allow rep clause for standard [wide_[wide_]]character
+
+ elsif Is_Standard_Character_Type (Enumtype) then
+ Error_Msg_N ("enumeration rep clause not allowed for this type", N);
+ return;
+
+ -- Check that the expression is a proper aggregate (no parentheses)
+
+ elsif Paren_Count (Aggr) /= 0 then
+ Error_Msg
+ ("extra parentheses surrounding aggregate not allowed",
+ First_Sloc (Aggr));
+ return;
+
+ -- All tests passed, so set rep clause in place
+
+ else
+ Set_Has_Enumeration_Rep_Clause (Enumtype);
+ Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
+ end if;
+
+ -- Now we process the aggregate. Note that we don't use the normal
+ -- aggregate code for this purpose, because we don't want any of the
+ -- normal expansion activities, and a number of special semantic
+ -- rules apply (including the component type being any integer type)
+
+ Elit := First_Literal (Enumtype);
+
+ -- First the positional entries if any
+
+ if Present (Expressions (Aggr)) then
+ Expr := First (Expressions (Aggr));
+ while Present (Expr) loop
+ if No (Elit) then
+ Error_Msg_N ("too many entries in aggregate", Expr);
+ return;
+ end if;
+
+ Val := Static_Integer (Expr);
+
+ -- Err signals that we found some incorrect entries processing
+ -- the list. The final checks for completeness and ordering are
+ -- skipped in this case.
+
+ if Val = No_Uint then
+ Err := True;
+ elsif Val < Lo or else Hi < Val then
+ Error_Msg_N ("value outside permitted range", Expr);
+ Err := True;
+ end if;
+
+ Set_Enumeration_Rep (Elit, Val);
+ Set_Enumeration_Rep_Expr (Elit, Expr);
+ Next (Expr);
+ Next (Elit);
+ end loop;
+ end if;
+
+ -- Now process the named entries if present
+
+ if Present (Component_Associations (Aggr)) then
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Assoc) loop
+ Choice := First (Choices (Assoc));
+
+ if Present (Next (Choice)) then
+ Error_Msg_N
+ ("multiple choice not allowed here", Next (Choice));
+ Err := True;
+ end if;
+
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N ("others choice not allowed here", Choice);
+ Err := True;
+
+ elsif Nkind (Choice) = N_Range then
+ -- ??? should allow zero/one element range here
+ Error_Msg_N ("range not allowed here", Choice);
+ Err := True;
+
+ else
+ Analyze_And_Resolve (Choice, Enumtype);
+
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ Error_Msg_N ("subtype name not allowed here", Choice);
+ Err := True;
+ -- ??? should allow static subtype with zero/one entry
+
+ elsif Etype (Choice) = Base_Type (Enumtype) then
+ if not Is_Static_Expression (Choice) then
+ Flag_Non_Static_Expr
+ ("non-static expression used for choice!", Choice);
+ Err := True;
+
+ else
+ Elit := Expr_Value_E (Choice);
+
+ if Present (Enumeration_Rep_Expr (Elit)) then
+ Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit));
+ Error_Msg_NE
+ ("representation for& previously given#",
+ Choice, Elit);
+ Err := True;
+ end if;
+
+ Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
+
+ Expr := Expression (Assoc);
+ Val := Static_Integer (Expr);
+
+ if Val = No_Uint then
+ Err := True;
+
+ elsif Val < Lo or else Hi < Val then
+ Error_Msg_N ("value outside permitted range", Expr);
+ Err := True;
+ end if;
+
+ Set_Enumeration_Rep (Elit, Val);
+ end if;
+ end if;
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ -- Aggregate is fully processed. Now we check that a full set of
+ -- representations was given, and that they are in range and in order.
+ -- These checks are only done if no other errors occurred.
+
+ if not Err then
+ Min := No_Uint;
+ Max := No_Uint;
+
+ Elit := First_Literal (Enumtype);
+ while Present (Elit) loop
+ if No (Enumeration_Rep_Expr (Elit)) then
+ Error_Msg_NE ("missing representation for&!", N, Elit);
+
+ else
+ Val := Enumeration_Rep (Elit);
+
+ if Min = No_Uint then
+ Min := Val;
+ end if;
+
+ if Val /= No_Uint then
+ if Max /= No_Uint and then Val <= Max then
+ Error_Msg_NE
+ ("enumeration value for& not ordered!",
+ Enumeration_Rep_Expr (Elit), Elit);
+ end if;
+
+ Max_Node := Enumeration_Rep_Expr (Elit);
+ Max := Val;
+ end if;
+
+ -- If there is at least one literal whose representation is not
+ -- equal to the Pos value, then note that this enumeration type
+ -- has a non-standard representation.
+
+ if Val /= Enumeration_Pos (Elit) then
+ Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
+ end if;
+ end if;
+
+ Next (Elit);
+ end loop;
+
+ -- Now set proper size information
+
+ declare
+ Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
+
+ begin
+ if Has_Size_Clause (Enumtype) then
+
+ -- All OK, if size is OK now
+
+ if RM_Size (Enumtype) >= Minsize then
+ null;
+
+ else
+ -- Try if we can get by with biasing
+
+ Minsize :=
+ UI_From_Int (Minimum_Size (Enumtype, Biased => True));
+
+ -- Error message if even biasing does not work
+
+ if RM_Size (Enumtype) < Minsize then
+ Error_Msg_Uint_1 := RM_Size (Enumtype);
+ Error_Msg_Uint_2 := Max;
+ Error_Msg_N
+ ("previously given size (^) is too small "
+ & "for this value (^)", Max_Node);
+
+ -- If biasing worked, indicate that we now have biased rep
+
+ else
+ Set_Biased
+ (Enumtype, Size_Clause (Enumtype), "size clause");
+ end if;
+ end if;
+
+ else
+ Set_RM_Size (Enumtype, Minsize);
+ Set_Enum_Esize (Enumtype);
+ end if;
+
+ Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype));
+ Set_Esize (Base_Type (Enumtype), Esize (Enumtype));
+ Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
+ end;
+ end if;
+
+ -- We repeat the too late test in case it froze itself!
+
+ if Rep_Item_Too_Late (Enumtype, N) then
+ null;
+ end if;
+ end Analyze_Enumeration_Representation_Clause;
+
+ ----------------------------
+ -- Analyze_Free_Statement --
+ ----------------------------
+
+ procedure Analyze_Free_Statement (N : Node_Id) is
+ begin
+ Analyze (Expression (N));
+ end Analyze_Free_Statement;
+
+ ---------------------------
+ -- Analyze_Freeze_Entity --
+ ---------------------------
+
+ procedure Analyze_Freeze_Entity (N : Node_Id) is
+ E : constant Entity_Id := Entity (N);
+
+ begin
+ -- Remember that we are processing a freezing entity. Required to
+ -- ensure correct decoration of internal entities associated with
+ -- interfaces (see New_Overloaded_Entity).
+
+ Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
+
+ -- For tagged types covering interfaces add internal entities that link
+ -- the primitives of the interfaces with the primitives that cover them.
+ -- Note: These entities were originally generated only when generating
+ -- code because their main purpose was to provide support to initialize
+ -- the secondary dispatch tables. They are now generated also when
+ -- compiling with no code generation to provide ASIS the relationship
+ -- between interface primitives and tagged type primitives. They are
+ -- also used to locate primitives covering interfaces when processing
+ -- generics (see Derive_Subprograms).
+
+ if Ada_Version >= Ada_2005
+ and then Ekind (E) = E_Record_Type
+ and then Is_Tagged_Type (E)
+ and then not Is_Interface (E)
+ and then Has_Interfaces (E)
+ then
+ -- This would be a good common place to call the routine that checks
+ -- overriding of interface primitives (and thus factorize calls to
+ -- Check_Abstract_Overriding located at different contexts in the
+ -- compiler). However, this is not possible because it causes
+ -- spurious errors in case of late overriding.
+
+ Add_Internal_Interface_Entities (E);
+ end if;
+
+ -- Check CPP types
+
+ if Ekind (E) = E_Record_Type
+ and then Is_CPP_Class (E)
+ and then Is_Tagged_Type (E)
+ and then Tagged_Type_Expansion
+ and then Expander_Active
+ then
+ if CPP_Num_Prims (E) = 0 then
+
+ -- If the CPP type has user defined components then it must import
+ -- primitives from C++. This is required because if the C++ class
+ -- has no primitives then the C++ compiler does not added the _tag
+ -- component to the type.
+
+ pragma Assert (Chars (First_Entity (E)) = Name_uTag);
+
+ if First_Entity (E) /= Last_Entity (E) then
+ Error_Msg_N
+ ("?'C'P'P type must import at least one primitive from C++",
+ E);
+ end if;
+ end if;
+
+ -- Check that all its primitives are abstract or imported from C++.
+ -- Check also availability of the C++ constructor.
+
+ declare
+ Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
+ Elmt : Elmt_Id;
+ Error_Reported : Boolean := False;
+ Prim : Node_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (E));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ if Comes_From_Source (Prim) then
+ if Is_Abstract_Subprogram (Prim) then
+ null;
+
+ elsif not Is_Imported (Prim)
+ or else Convention (Prim) /= Convention_CPP
+ then
+ Error_Msg_N
+ ("?primitives of 'C'P'P types must be imported from C++"
+ & " or abstract", Prim);
+
+ elsif not Has_Constructors
+ and then not Error_Reported
+ then
+ Error_Msg_Name_1 := Chars (E);
+ Error_Msg_N
+ ("?'C'P'P constructor required for type %", Prim);
+ Error_Reported := True;
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+
+ Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
+ end Analyze_Freeze_Entity;
+
+ ------------------------------------------
+ -- Analyze_Record_Representation_Clause --
+ ------------------------------------------
+
+ -- Note: we check as much as we can here, but we can't do any checks
+ -- based on the position values (e.g. overlap checks) until freeze time
+ -- because especially in Ada 2005 (machine scalar mode), the processing
+ -- for non-standard bit order can substantially change the positions.
+ -- See procedure Check_Record_Representation_Clause (called from Freeze)
+ -- for the remainder of this processing.
+
+ procedure Analyze_Record_Representation_Clause (N : Node_Id) is
+ Ident : constant Node_Id := Identifier (N);
+ Biased : Boolean;
+ CC : Node_Id;
+ Comp : Entity_Id;
+ Fbit : Uint;
+ Hbit : Uint := Uint_0;
+ Lbit : Uint;
+ Ocomp : Entity_Id;
+ Posit : Uint;
+ Rectype : Entity_Id;
+
+ CR_Pragma : Node_Id := Empty;
+ -- Points to N_Pragma node if Complete_Representation pragma present
+
+ begin
+ if Ignore_Rep_Clauses then
+ return;
+ end if;
+
+ Find_Type (Ident);
+ Rectype := Entity (Ident);
+
+ if Rectype = Any_Type
+ or else Rep_Item_Too_Early (Rectype, N)
+ then
+ return;
+ else
+ Rectype := Underlying_Type (Rectype);
+ end if;
+
+ -- First some basic error checks
+
+ if not Is_Record_Type (Rectype) then
+ Error_Msg_NE
+ ("record type required, found}", Ident, First_Subtype (Rectype));
+ return;
+
+ elsif Scope (Rectype) /= Current_Scope then
+ Error_Msg_N ("type must be declared in this scope", N);
+ return;
+
+ elsif not Is_First_Subtype (Rectype) then
+ Error_Msg_N ("cannot give record rep clause for subtype", N);
+ return;
+
+ elsif Has_Record_Rep_Clause (Rectype) then
+ Error_Msg_N ("duplicate record rep clause ignored", N);
+ return;
+
+ elsif Rep_Item_Too_Late (Rectype, N) then
+ return;
+ end if;
+
+ if Present (Mod_Clause (N)) then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ M : constant Node_Id := Mod_Clause (N);
+ P : constant List_Id := Pragmas_Before (M);
+ AtM_Nod : Node_Id;
+
+ Mod_Val : Uint;
+ pragma Warnings (Off, Mod_Val);
+
+ begin
+ Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("mod clause is an obsolescent feature (RM J.8)?", N);
+ Error_Msg_N
+ ("\use alignment attribute definition clause instead?", N);
+ end if;
+
+ if Present (P) then
+ Analyze_List (P);
+ end if;
+
+ -- In ASIS_Mode mode, expansion is disabled, but we must convert
+ -- the Mod clause into an alignment clause anyway, so that the
+ -- back-end can compute and back-annotate properly the size and
+ -- alignment of types that may include this record.
+
+ -- This seems dubious, this destroys the source tree in a manner
+ -- not detectable by ASIS ???
+
+ if Operating_Mode = Check_Semantics
+ and then ASIS_Mode
+ then
+ AtM_Nod :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (Base_Type (Rectype), Loc),
+ Chars => Name_Alignment,
+ Expression => Relocate_Node (Expression (M)));
+
+ Set_From_At_Mod (AtM_Nod);
+ Insert_After (N, AtM_Nod);
+ Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
+ Set_Mod_Clause (N, Empty);
+
+ else
+ -- Get the alignment value to perform error checking
+
+ Mod_Val := Get_Alignment_Value (Expression (M));
+ end if;
+ end;
+ end if;
+
+ -- For untagged types, clear any existing component clauses for the
+ -- type. If the type is derived, this is what allows us to override
+ -- a rep clause for the parent. For type extensions, the representation
+ -- of the inherited components is inherited, so we want to keep previous
+ -- component clauses for completeness.
+
+ if not Is_Tagged_Type (Rectype) then
+ Comp := First_Component_Or_Discriminant (Rectype);
+ while Present (Comp) loop
+ Set_Component_Clause (Comp, Empty);
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end if;
+
+ -- All done if no component clauses
+
+ CC := First (Component_Clauses (N));
+
+ if No (CC) then
+ return;
+ end if;
+
+ -- A representation like this applies to the base type
+
+ Set_Has_Record_Rep_Clause (Base_Type (Rectype));
+ Set_Has_Non_Standard_Rep (Base_Type (Rectype));
+ Set_Has_Specified_Layout (Base_Type (Rectype));
+
+ -- Process the component clauses
+
+ while Present (CC) loop
+
+ -- Pragma
+
+ if Nkind (CC) = N_Pragma then
+ Analyze (CC);
+
+ -- The only pragma of interest is Complete_Representation
+
+ if Pragma_Name (CC) = Name_Complete_Representation then
+ CR_Pragma := CC;
+ end if;
+
+ -- Processing for real component clause
+
+ else
+ Posit := Static_Integer (Position (CC));
+ Fbit := Static_Integer (First_Bit (CC));
+ Lbit := Static_Integer (Last_Bit (CC));
+
+ if Posit /= No_Uint
+ and then Fbit /= No_Uint
+ and then Lbit /= No_Uint
+ then
+ if Posit < 0 then
+ Error_Msg_N
+ ("position cannot be negative", Position (CC));
+
+ elsif Fbit < 0 then
+ Error_Msg_N
+ ("first bit cannot be negative", First_Bit (CC));
+
+ -- The Last_Bit specified in a component clause must not be
+ -- less than the First_Bit minus one (RM-13.5.1(10)).
+
+ elsif Lbit < Fbit - 1 then
+ Error_Msg_N
+ ("last bit cannot be less than first bit minus one",
+ Last_Bit (CC));
+
+ -- Values look OK, so find the corresponding record component
+ -- Even though the syntax allows an attribute reference for
+ -- implementation-defined components, GNAT does not allow the
+ -- tag to get an explicit position.
+
+ elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
+ if Attribute_Name (Component_Name (CC)) = Name_Tag then
+ Error_Msg_N ("position of tag cannot be specified", CC);
+ else
+ Error_Msg_N ("illegal component name", CC);
+ end if;
+
+ else
+ Comp := First_Entity (Rectype);
+ while Present (Comp) loop
+ exit when Chars (Comp) = Chars (Component_Name (CC));
+ Next_Entity (Comp);
+ end loop;
+
+ if No (Comp) then
+
+ -- Maybe component of base type that is absent from
+ -- statically constrained first subtype.
+
+ Comp := First_Entity (Base_Type (Rectype));
+ while Present (Comp) loop
+ exit when Chars (Comp) = Chars (Component_Name (CC));
+ Next_Entity (Comp);
+ end loop;
+ end if;
+
+ if No (Comp) then
+ Error_Msg_N
+ ("component clause is for non-existent field", CC);
+
+ -- Ada 2012 (AI05-0026): Any name that denotes a
+ -- discriminant of an object of an unchecked union type
+ -- shall not occur within a record_representation_clause.
+
+ -- The general restriction of using record rep clauses on
+ -- Unchecked_Union types has now been lifted. Since it is
+ -- possible to introduce a record rep clause which mentions
+ -- the discriminant of an Unchecked_Union in non-Ada 2012
+ -- code, this check is applied to all versions of the
+ -- language.
+
+ elsif Ekind (Comp) = E_Discriminant
+ and then Is_Unchecked_Union (Rectype)
+ then
+ Error_Msg_N
+ ("cannot reference discriminant of Unchecked_Union",
+ Component_Name (CC));
+
+ elsif Present (Component_Clause (Comp)) then
+
+ -- Diagnose duplicate rep clause, or check consistency
+ -- if this is an inherited component. In a double fault,
+ -- there may be a duplicate inconsistent clause for an
+ -- inherited component.
+
+ if Scope (Original_Record_Component (Comp)) = Rectype
+ or else Parent (Component_Clause (Comp)) = N
+ then
+ Error_Msg_Sloc := Sloc (Component_Clause (Comp));
+ Error_Msg_N ("component clause previously given#", CC);
+
+ else
+ declare
+ Rep1 : constant Node_Id := Component_Clause (Comp);
+ begin
+ if Intval (Position (Rep1)) /=
+ Intval (Position (CC))
+ or else Intval (First_Bit (Rep1)) /=
+ Intval (First_Bit (CC))
+ or else Intval (Last_Bit (Rep1)) /=
+ Intval (Last_Bit (CC))
+ then
+ Error_Msg_N ("component clause inconsistent "
+ & "with representation of ancestor", CC);
+ elsif Warn_On_Redundant_Constructs then
+ Error_Msg_N ("?redundant component clause "
+ & "for inherited component!", CC);
+ end if;
+ end;
+ end if;
+
+ -- Normal case where this is the first component clause we
+ -- have seen for this entity, so set it up properly.
+
+ else
+ -- Make reference for field in record rep clause and set
+ -- appropriate entity field in the field identifier.
+
+ Generate_Reference
+ (Comp, Component_Name (CC), Set_Ref => False);
+ Set_Entity (Component_Name (CC), Comp);
+
+ -- Update Fbit and Lbit to the actual bit number
+
+ Fbit := Fbit + UI_From_Int (SSU) * Posit;
+ Lbit := Lbit + UI_From_Int (SSU) * Posit;
+
+ if Has_Size_Clause (Rectype)
+ and then Esize (Rectype) <= Lbit
+ then
+ Error_Msg_N
+ ("bit number out of range of specified size",
+ Last_Bit (CC));
+ else
+ Set_Component_Clause (Comp, CC);
+ Set_Component_Bit_Offset (Comp, Fbit);
+ Set_Esize (Comp, 1 + (Lbit - Fbit));
+ Set_Normalized_First_Bit (Comp, Fbit mod SSU);
+ Set_Normalized_Position (Comp, Fbit / SSU);
+
+ if Warn_On_Overridden_Size
+ and then Has_Size_Clause (Etype (Comp))
+ and then RM_Size (Etype (Comp)) /= Esize (Comp)
+ then
+ Error_Msg_NE
+ ("?component size overrides size clause for&",
+ Component_Name (CC), Etype (Comp));
+ end if;
+
+ -- This information is also set in the corresponding
+ -- component of the base type, found by accessing the
+ -- Original_Record_Component link if it is present.
+
+ Ocomp := Original_Record_Component (Comp);
+
+ if Hbit < Lbit then
+ Hbit := Lbit;
+ end if;
+
+ Check_Size
+ (Component_Name (CC),
+ Etype (Comp),
+ Esize (Comp),
+ Biased);
+
+ Set_Biased
+ (Comp, First_Node (CC), "component clause", Biased);
+
+ if Present (Ocomp) then
+ Set_Component_Clause (Ocomp, CC);
+ Set_Component_Bit_Offset (Ocomp, Fbit);
+ Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
+ Set_Normalized_Position (Ocomp, Fbit / SSU);
+ Set_Esize (Ocomp, 1 + (Lbit - Fbit));
+
+ Set_Normalized_Position_Max
+ (Ocomp, Normalized_Position (Ocomp));
+
+ -- Note: we don't use Set_Biased here, because we
+ -- already gave a warning above if needed, and we
+ -- would get a duplicate for the same name here.
+
+ Set_Has_Biased_Representation
+ (Ocomp, Has_Biased_Representation (Comp));
+ end if;
+
+ if Esize (Comp) < 0 then
+ Error_Msg_N ("component size is negative", CC);
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ Next (CC);
+ end loop;
+
+ -- Check missing components if Complete_Representation pragma appeared
+
+ if Present (CR_Pragma) then
+ Comp := First_Component_Or_Discriminant (Rectype);
+ while Present (Comp) loop
+ if No (Component_Clause (Comp)) then
+ Error_Msg_NE
+ ("missing component clause for &", CR_Pragma, Comp);
+ end if;
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+
+ -- If no Complete_Representation pragma, warn if missing components
+
+ elsif Warn_On_Unrepped_Components then
+ declare
+ Num_Repped_Components : Nat := 0;
+ Num_Unrepped_Components : Nat := 0;
+
+ begin
+ -- First count number of repped and unrepped components
+
+ Comp := First_Component_Or_Discriminant (Rectype);
+ while Present (Comp) loop
+ if Present (Component_Clause (Comp)) then
+ Num_Repped_Components := Num_Repped_Components + 1;
+ else
+ Num_Unrepped_Components := Num_Unrepped_Components + 1;
+ end if;
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+
+ -- We are only interested in the case where there is at least one
+ -- unrepped component, and at least half the components have rep
+ -- clauses. We figure that if less than half have them, then the
+ -- partial rep clause is really intentional. If the component
+ -- type has no underlying type set at this point (as for a generic
+ -- formal type), we don't know enough to give a warning on the
+ -- component.
+
+ if Num_Unrepped_Components > 0
+ and then Num_Unrepped_Components < Num_Repped_Components
+ then
+ Comp := First_Component_Or_Discriminant (Rectype);
+ while Present (Comp) loop
+ if No (Component_Clause (Comp))
+ and then Comes_From_Source (Comp)
+ and then Present (Underlying_Type (Etype (Comp)))
+ and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
+ or else Size_Known_At_Compile_Time
+ (Underlying_Type (Etype (Comp))))
+ and then not Has_Warnings_Off (Rectype)
+ then
+ Error_Msg_Sloc := Sloc (Comp);
+ Error_Msg_NE
+ ("?no component clause given for & declared #",
+ N, Comp);
+ end if;
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end if;
+ end;
+ end if;
+ end Analyze_Record_Representation_Clause;
+
+ -----------------------------------
+ -- Check_Constant_Address_Clause --
+ -----------------------------------
+
+ procedure Check_Constant_Address_Clause
+ (Expr : Node_Id;
+ U_Ent : Entity_Id)
+ is
+ procedure Check_At_Constant_Address (Nod : Node_Id);
+ -- Checks that the given node N represents a name whose 'Address is
+ -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the
+ -- address value is the same at the point of declaration of U_Ent and at
+ -- the time of elaboration of the address clause.
+
+ procedure Check_Expr_Constants (Nod : Node_Id);
+ -- Checks that Nod meets the requirements for a constant address clause
+ -- in the sense of the enclosing procedure.
+
+ procedure Check_List_Constants (Lst : List_Id);
+ -- Check that all elements of list Lst meet the requirements for a
+ -- constant address clause in the sense of the enclosing procedure.
+
+ -------------------------------
+ -- Check_At_Constant_Address --
+ -------------------------------
+
+ procedure Check_At_Constant_Address (Nod : Node_Id) is
+ begin
+ if Is_Entity_Name (Nod) then
+ if Present (Address_Clause (Entity ((Nod)))) then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_NE
+ ("address for& cannot" &
+ " depend on another address clause! (RM 13.1(22))!",
+ Nod, U_Ent);
+
+ elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
+ and then Sloc (U_Ent) < Sloc (Entity (Nod))
+ then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_Node_2 := U_Ent;
+ Error_Msg_NE
+ ("\& must be defined before & (RM 13.1(22))!",
+ Nod, Entity (Nod));
+ end if;
+
+ elsif Nkind (Nod) = N_Selected_Component then
+ declare
+ T : constant Entity_Id := Etype (Prefix (Nod));
+
+ begin
+ if (Is_Record_Type (T)
+ and then Has_Discriminants (T))
+ or else
+ (Is_Access_Type (T)
+ and then Is_Record_Type (Designated_Type (T))
+ and then Has_Discriminants (Designated_Type (T)))
+ then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_N
+ ("\address cannot depend on component" &
+ " of discriminated record (RM 13.1(22))!",
+ Nod);
+ else
+ Check_At_Constant_Address (Prefix (Nod));
+ end if;
+ end;
+
+ elsif Nkind (Nod) = N_Indexed_Component then
+ Check_At_Constant_Address (Prefix (Nod));
+ Check_List_Constants (Expressions (Nod));
+
+ else
+ Check_Expr_Constants (Nod);
+ end if;
+ end Check_At_Constant_Address;
+
+ --------------------------
+ -- Check_Expr_Constants --
+ --------------------------
+
+ procedure Check_Expr_Constants (Nod : Node_Id) is
+ Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
+ Ent : Entity_Id := Empty;
+
+ begin
+ if Nkind (Nod) in N_Has_Etype
+ and then Etype (Nod) = Any_Type
+ then
+ return;
+ end if;
+
+ case Nkind (Nod) is
+ when N_Empty | N_Error =>
+ return;
+
+ when N_Identifier | N_Expanded_Name =>
+ Ent := Entity (Nod);
+
+ -- We need to look at the original node if it is different
+ -- from the node, since we may have rewritten things and
+ -- substituted an identifier representing the rewrite.
+
+ if Original_Node (Nod) /= Nod then
+ Check_Expr_Constants (Original_Node (Nod));
+
+ -- If the node is an object declaration without initial
+ -- value, some code has been expanded, and the expression
+ -- is not constant, even if the constituents might be
+ -- acceptable, as in A'Address + offset.
+
+ if Ekind (Ent) = E_Variable
+ and then
+ Nkind (Declaration_Node (Ent)) = N_Object_Declaration
+ and then
+ No (Expression (Declaration_Node (Ent)))
+ then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+
+ -- If entity is constant, it may be the result of expanding
+ -- a check. We must verify that its declaration appears
+ -- before the object in question, else we also reject the
+ -- address clause.
+
+ elsif Ekind (Ent) = E_Constant
+ and then In_Same_Source_Unit (Ent, U_Ent)
+ and then Sloc (Ent) > Loc_U_Ent
+ then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ end if;
+
+ return;
+ end if;
+
+ -- Otherwise look at the identifier and see if it is OK
+
+ if Ekind_In (Ent, E_Named_Integer, E_Named_Real)
+ or else Is_Type (Ent)
+ then
+ return;
+
+ elsif
+ Ekind (Ent) = E_Constant
+ or else
+ Ekind (Ent) = E_In_Parameter
+ then
+ -- This is the case where we must have Ent defined before
+ -- U_Ent. Clearly if they are in different units this
+ -- requirement is met since the unit containing Ent is
+ -- already processed.
+
+ if not In_Same_Source_Unit (Ent, U_Ent) then
+ return;
+
+ -- Otherwise location of Ent must be before the location
+ -- of U_Ent, that's what prior defined means.
+
+ elsif Sloc (Ent) < Loc_U_Ent then
+ return;
+
+ else
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_Node_2 := U_Ent;
+ Error_Msg_NE
+ ("\& must be defined before & (RM 13.1(22))!",
+ Nod, Ent);
+ end if;
+
+ elsif Nkind (Original_Node (Nod)) = N_Function_Call then
+ Check_Expr_Constants (Original_Node (Nod));
+
+ else
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+
+ if Comes_From_Source (Ent) then
+ Error_Msg_NE
+ ("\reference to variable& not allowed"
+ & " (RM 13.1(22))!", Nod, Ent);
+ else
+ Error_Msg_N
+ ("non-static expression not allowed"
+ & " (RM 13.1(22))!", Nod);
+ end if;
+ end if;
+
+ when N_Integer_Literal =>
+
+ -- If this is a rewritten unchecked conversion, in a system
+ -- where Address is an integer type, always use the base type
+ -- for a literal value. This is user-friendly and prevents
+ -- order-of-elaboration issues with instances of unchecked
+ -- conversion.
+
+ if Nkind (Original_Node (Nod)) = N_Function_Call then
+ Set_Etype (Nod, Base_Type (Etype (Nod)));
+ end if;
+
+ when N_Real_Literal |
+ N_String_Literal |
+ N_Character_Literal =>
+ return;
+
+ when N_Range =>
+ Check_Expr_Constants (Low_Bound (Nod));
+ Check_Expr_Constants (High_Bound (Nod));
+
+ when N_Explicit_Dereference =>
+ Check_Expr_Constants (Prefix (Nod));
+
+ when N_Indexed_Component =>
+ Check_Expr_Constants (Prefix (Nod));
+ Check_List_Constants (Expressions (Nod));
+
+ when N_Slice =>
+ Check_Expr_Constants (Prefix (Nod));
+ Check_Expr_Constants (Discrete_Range (Nod));
+
+ when N_Selected_Component =>
+ Check_Expr_Constants (Prefix (Nod));
+
+ when N_Attribute_Reference =>
+ if Attribute_Name (Nod) = Name_Address
+ or else
+ Attribute_Name (Nod) = Name_Access
+ or else
+ Attribute_Name (Nod) = Name_Unchecked_Access
+ or else
+ Attribute_Name (Nod) = Name_Unrestricted_Access
+ then
+ Check_At_Constant_Address (Prefix (Nod));
+
+ else
+ Check_Expr_Constants (Prefix (Nod));
+ Check_List_Constants (Expressions (Nod));
+ end if;
+
+ when N_Aggregate =>
+ Check_List_Constants (Component_Associations (Nod));
+ Check_List_Constants (Expressions (Nod));
+
+ when N_Component_Association =>
+ Check_Expr_Constants (Expression (Nod));
+
+ when N_Extension_Aggregate =>
+ Check_Expr_Constants (Ancestor_Part (Nod));
+ Check_List_Constants (Component_Associations (Nod));
+ Check_List_Constants (Expressions (Nod));
+
+ when N_Null =>
+ return;
+
+ when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
+ Check_Expr_Constants (Left_Opnd (Nod));
+ Check_Expr_Constants (Right_Opnd (Nod));
+
+ when N_Unary_Op =>
+ Check_Expr_Constants (Right_Opnd (Nod));
+
+ when N_Type_Conversion |
+ N_Qualified_Expression |
+ N_Allocator =>
+ Check_Expr_Constants (Expression (Nod));
+
+ when N_Unchecked_Type_Conversion =>
+ Check_Expr_Constants (Expression (Nod));
+
+ -- If this is a rewritten unchecked conversion, subtypes in
+ -- this node are those created within the instance. To avoid
+ -- order of elaboration issues, replace them with their base
+ -- types. Note that address clauses can cause order of
+ -- elaboration problems because they are elaborated by the
+ -- back-end at the point of definition, and may mention
+ -- entities declared in between (as long as everything is
+ -- static). It is user-friendly to allow unchecked conversions
+ -- in this context.
+
+ if Nkind (Original_Node (Nod)) = N_Function_Call then
+ Set_Etype (Expression (Nod),
+ Base_Type (Etype (Expression (Nod))));
+ Set_Etype (Nod, Base_Type (Etype (Nod)));
+ end if;
+
+ when N_Function_Call =>
+ if not Is_Pure (Entity (Name (Nod))) then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+
+ Error_Msg_NE
+ ("\function & is not pure (RM 13.1(22))!",
+ Nod, Entity (Name (Nod)));
+
+ else
+ Check_List_Constants (Parameter_Associations (Nod));
+ end if;
+
+ when N_Parameter_Association =>
+ Check_Expr_Constants (Explicit_Actual_Parameter (Nod));
+
+ when others =>
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_NE
+ ("\must be constant defined before& (RM 13.1(22))!",
+ Nod, U_Ent);
+ end case;
+ end Check_Expr_Constants;