+2011-08-02 Robert Dewar <dewar@adacore.com>
+
+ * sem_attr.adb: Minor reformatting.
+
+2011-08-02 Robert Dewar <dewar@adacore.com>
+
+ * einfo.adb (Has_Default_Aspect): Replaces Has_Default_Value
+ (Has_Default_Component_Value): Removed
+ * einfo.ads Comment updates
+ (Has_Default_Aspect): Replaces Has_Default_Value
+ (Has_Default_Component_Value): Removed
+ * exp_ch13.adb
+ (Expand_N_Freeze_Entity): Handle Default[_Component]_Value aspects
+ * exp_ch3.adb
+ (Build_Array_Init_Proc): Handle Default_[Component_]Value aspects
+ (Get_Simple_Init_Val): Handle Default_Value aspect
+ (Needs_Simple_Initialization): Handle Default_Value aspect
+ * exp_ch3.ads: Needs_Simple_Initialization
+ * freeze.adb (Freeze_Entity): Handle Default_[Component_]Value aspect
+ * par-prag.adb (Pragma_Default[_Component]Value) Removed
+ * sem_ch13.adb
+ (Analyze_Aspect_Specifications): Fix Default[_Component]_Value aspects
+ * sem_prag.adb (Pragma_Default[_Component]Value) Removed
+ * snames.ads-tmpl (Pragma_Default[_Component]Value) Removed
+
+2011-08-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Iterator_Specification): use base type to locate
+ package containing iteration primitives.
+ exp_ch5.adb (Expand_Iterator_Loop): ditto.
+
2011-08-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Iteration_Scheme): For an Ada2012 iterator with
* s-stusta.adb (Print): Make sure Pos is always initialized to a
suitable value.
-2011-08-02 Ed Falis <falis@adacore.com>
-
- * init.c: Fix conditional compilation so that the fp initialization is
- peformed for the MILS VxWorks Guest OS.
-
2011-08-02 Geert Bosch <bosch@adacore.com>
* a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image.
-- Referenced_As_LHS Flag36
-- Is_Known_Non_Null Flag37
-- Can_Never_Be_Null Flag38
- -- Has_Default_Value Flag39
+ -- Has_Default_Aspect Flag39
-- Body_Needed_For_SAL Flag40
-- Treat_As_Volatile Flag41
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
- -- Has_Default_Component_Value Flag151
-- Entry_Accepted Flag152
-- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154
-- Is_Safe_To_Reevaluate Flag249
-- Has_Predicates Flag250
+ -- (unused) Flag151
-- (unused) Flag251
-- (unused) Flag252
-- (unused) Flag253
return Flag119 (Id);
end Has_Convention_Pragma;
- function Has_Default_Component_Value (Id : E) return B is
+ function Has_Default_Aspect (Id : E) return B is
begin
- pragma Assert (Is_Array_Type (Id));
- return Flag151 (Base_Type (Id));
- end Has_Default_Component_Value;
-
- function Has_Default_Value (Id : E) return B is
- begin
- pragma Assert (Is_Scalar_Type (Id));
return Flag39 (Base_Type (Id));
- end Has_Default_Value;
+ end Has_Default_Aspect;
function Has_Delayed_Aspects (Id : E) return B is
begin
Set_Flag119 (Id, V);
end Set_Has_Convention_Pragma;
- procedure Set_Has_Default_Component_Value (Id : E; V : B := True) is
+ procedure Set_Has_Default_Aspect (Id : E; V : B := True) is
begin
- pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
- Set_Flag151 (Id, V);
- end Set_Has_Default_Component_Value;
-
- procedure Set_Has_Default_Value (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Scalar_Type (Id) and then Is_Base_Type (Id));
+ pragma Assert
+ ((Is_Scalar_Type (Id) or else Is_Array_Type (Id))
+ and then Is_Base_Type (Id));
Set_Flag39 (Id, V);
- end Set_Has_Default_Value;
+ end Set_Has_Default_Aspect;
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
begin
W ("Has_Controlled_Component", Flag43 (Id));
W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Convention_Pragma", Flag119 (Id));
- W ("Has_Default_Component_Value", Flag151 (Id));
- W ("Has_Default_Value", Flag39 (Id));
+ W ("Has_Default_Aspect", Flag39 (Id));
W ("Has_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Discriminants", Flag5 (Id));
-- the value of the entry barrier.
-- Base_Type (synthesized)
--- Applies to all type entities. Returns the base type of a type or
--- subtype. The base type of a type is the type itself. The base type
--- of a subtype is the type that it constrains (which is always a type
--- entity, not some other subtype). Note that in the case of a subtype
--- of a private type, it is possible for the base type attribute to
--- return a private type, even if the subtype to which it applies is
--- non-private. See also Implementation_Base_Type. Note: it is allowed
--- to apply Base_Type to other than a type, in which case it simply
--- returns the entity unchanged.
+-- Applies to all type and subtype entities. Returns the base type of a
+-- type or subtype. The base type of a type is the type itself. The base
+-- type of a subtype is the type that it constrains (which is always
+-- a type entity, not some other subtype). Note that in the case of a
+-- subtype of a private type, it is possible for the base type attribute
+-- to return a private type, even if the subtype to which it applies is
+-- non-private. See also Implementation_Base_Type. Note: it is allowed to
+-- apply Base_Type to other than a type, in which case it simply returns
+-- the entity unchanged.
-- Block_Node (Node11)
-- Present in block entities. Points to the identifier in the
-- function of a tagged type which can dispatch on result.
-- Has_Controlled_Component (Flag43) [base type only]
--- Present in all entities. Set only for composite type entities which
--- contain a component that either is a controlled type, or itself
--- contains controlled component (i.e. either Has_Controlled_Component
--- or Is_Controlled is set for at least one component).
+-- Present in all type and subtype entities. Set only for composite type
+-- entities which contain a component that either is a controlled type,
+-- or itself contains controlled component (i.e. either Is_Controlled or
+-- Has_Controlled_Component is set for at least one component).
-- Has_Convention_Pragma (Flag119)
-- Present in all entities. Set true for an entity for which a valid
-- node must be generated for the entity at its freezing point. See
-- separate section ("Delayed Freezing and Elaboration") for details.
--- Has_Default_Component_Value (Flag151) [root type only]
--- Present in array types. Set on a base type to indicate that the base
--- type and all its subtypes have a Default_Component_Value aspect. If
--- this flag is True, then there will be a pragma Default_Component_Value
--- chained to the Rep_Item list for the base type.
-
--- Has_Default_Value (Flag39) [base type only]
--- Present in scalar types. Set on a base type to indicate that the base
--- type and all its subtypes have a Default_Value aspect. If this flag is
--- True, then there will always be a pragma Default_Value chained to the
--- Rep_Item list for the base type.
+-- Has_Default_Aspect (Flag39) [base type only]
+-- Present in entities for types and subtypes, set for scalar types with
+-- a Default_Value aspect and array types with a Default_Component_Value
+-- apsect. If this flag is set, then a corresponding aspect specification
+-- node will be present on the rep item chain for the entity.
-- Has_Discriminants (Flag5)
-- Present in all types and subtypes. For types that are allowed to have
-- case since we allow multiple occurrences of this pragma anyway.
-- Has_Pragma_Pack (Flag121) [implementation base type only]
--- Present in all entities. If set, indicates that a valid pragma Pack
--- was given for the type. Note that this flag is not inherited by
--- derived type. See also the Is_Packed flag.
+-- Present in array and record type entities. If set, indicates that a
+-- valid pragma Pack was given for the type. Note that this flag is not
+-- inherited by derived type. See also the Is_Packed flag.
-- Has_Pragma_Pure (Flag203)
-- Present in all entities. If set, indicates that a valid pragma Pure
-- Checks_May_Be_Suppressed (Flag31)
-- Debug_Info_Off (Flag166)
-- Has_Anon_Block_Suffix (Flag201)
- -- Has_Controlled_Component (Flag43) (base type only)
-- Has_Convention_Pragma (Flag119)
-- Has_Delayed_Aspects (Flag200)
-- Has_Delayed_Freeze (Flag18)
-- Has_Pragma_Elaborate_Body (Flag150)
-- Has_Pragma_Inline (Flag157)
-- Has_Pragma_Inline_Always (Flag230)
- -- Has_Pragma_Pack (Flag121) (base type only)
-- Has_Pragma_Pure (Flag203)
-- Has_Pragma_Pure_Function (Flag179)
-- Has_Pragma_Thread_Local_Storage (Flag169)
-- Has_Completion_In_Body (Flag71)
-- Has_Complex_Representation (Flag140) (base type only)
-- Has_Constrained_Partial_View (Flag187)
+ -- Has_Controlled_Component (Flag43) (base type only)
+ -- Has_Default_Aspect (Flag39) (base type only)
-- Has_Discriminants (Flag5)
-- Has_Inheritable_Invariants (Flag248)
-- Has_Invariants (Flag232)
-- Packed_Array_Type (Node23)
-- Component_Alignment (special) (base type only)
-- Has_Component_Size_Clause (Flag68) (base type only)
- -- Has_Default_Component_Value (Flag151) (base type only)
+ -- Has_Pragma_Pack (Flag121) (impl base type only)
-- Is_Aliased (Flag15)
-- Is_Constrained (Flag12)
-- Next_Index (synth)
-- Scalar_Range (Node20)
-- Delta_Value (Ureal18)
-- Small_Value (Ureal21)
- -- Has_Default_Value (Flag39) (base type only)
-- Has_Machine_Radix_Clause (Flag83)
-- Machine_Radix_10 (Flag84)
-- Aft_Value (synth)
-- Static_Predicate (List25)
-- Has_Biased_Representation (Flag139)
-- Has_Contiguous_Rep (Flag181)
- -- Has_Default_Value (Flag39) (base type only)
-- Has_Enumeration_Rep_Clause (Flag66)
-- Has_Pragma_Ordered (Flag198) (base type only)
-- Nonzero_Is_True (Flag162) (base type only)
-- Digits_Value (Uint17)
-- Float_Rep (Uint10) (Float_Rep_Kind)
-- Scalar_Range (Node20)
- -- Has_Default_Value (Flag39) (base type only)
-- Machine_Emax_Value (synth)
-- Machine_Emin_Value (synth)
-- Machine_Mantissa_Value (synth)
-- Static_Predicate (List25)
-- Non_Binary_Modulus (Flag58) (base type only)
-- Has_Biased_Representation (Flag139)
- -- Has_Default_Value (Flag39) (base type only)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
-- Delta_Value (Ureal18)
-- Scalar_Range (Node20)
-- Small_Value (Ureal21)
- -- Has_Default_Value (Flag39) (base type only)
-- Has_Small_Clause (Flag67)
-- Aft_Value (synth)
-- Type_Low_Bound (synth)
-- C_Pass_By_Copy (Flag125) (base type only)
-- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Has_External_Tag_Rep_Clause (Flag110)
+ -- Has_Pragma_Pack (Flag121) (impl base type only)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Static_Discriminants (Flag211) (subtype only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Scalar_Range (Node20)
-- Static_Predicate (List25)
-- Has_Biased_Representation (Flag139)
- -- Has_Default_Value (Flag39) (base type only)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
function Has_Controlled_Component (Id : E) return B;
function Has_Controlling_Result (Id : E) return B;
function Has_Convention_Pragma (Id : E) return B;
- function Has_Default_Component_Value (Id : E) return B;
- function Has_Default_Value (Id : E) return B;
+ function Has_Default_Aspect (Id : E) return B;
function Has_Delayed_Aspects (Id : E) return B;
function Has_Delayed_Freeze (Id : E) return B;
function Has_Discriminants (Id : E) return B;
procedure Set_Has_Controlled_Component (Id : E; V : B := True);
procedure Set_Has_Controlling_Result (Id : E; V : B := True);
procedure Set_Has_Convention_Pragma (Id : E; V : B := True);
- procedure Set_Has_Default_Component_Value (Id : E; V : B := True);
- procedure Set_Has_Default_Value (Id : E; V : B := True);
+ procedure Set_Has_Default_Aspect (Id : E; V : B := True);
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True);
procedure Set_Has_Delayed_Freeze (Id : E; V : B := True);
procedure Set_Has_Discriminants (Id : E; V : B := True);
pragma Inline (Has_Controlled_Component);
pragma Inline (Has_Controlling_Result);
pragma Inline (Has_Convention_Pragma);
- pragma Inline (Has_Default_Component_Value);
- pragma Inline (Has_Default_Value);
+ pragma Inline (Has_Default_Aspect);
pragma Inline (Has_Delayed_Aspects);
pragma Inline (Has_Delayed_Freeze);
pragma Inline (Has_Discriminants);
pragma Inline (Set_Has_Controlled_Component);
pragma Inline (Set_Has_Controlling_Result);
pragma Inline (Set_Has_Convention_Pragma);
- pragma Inline (Set_Has_Default_Component_Value);
- pragma Inline (Set_Has_Default_Value);
+ pragma Inline (Set_Has_Default_Aspect);
pragma Inline (Set_Has_Delayed_Aspects);
pragma Inline (Set_Has_Delayed_Freeze);
pragma Inline (Set_Has_Discriminants);
and then Entity (Ritem) = E
then
Aitem := Aspect_Rep_Item (Ritem);
- pragma Assert (Is_Delayed_Aspect (Aitem));
- Insert_Before (N, Aitem);
+
+ -- Skip this for aspects (e.g. Current_Value) for which
+ -- there is no corresponding pragma or attribute.
+
+ if Present (Aitem) then
+ pragma Assert (Is_Delayed_Aspect (Aitem));
+ Insert_Before (N, Aitem);
+ end if;
end if;
Next_Rep_Item (Ritem);
Prefix => Make_Identifier (Loc, Name_uInit),
Expressions => Index_List);
- if Needs_Simple_Initialization (Comp_Type) then
+ if Has_Default_Aspect (A_Type) then
Set_Assignment_OK (Comp);
return New_List (
Make_Assignment_Statement (Loc,
- Name => Comp,
+ Name => Comp,
+ Expression =>
+ Convert_To (Comp_Type,
+ Expression
+ (Get_Rep_Item_For_Entity
+ (First_Subtype (A_Type),
+ Name_Default_Component_Value)))));
+
+ elsif Needs_Simple_Initialization (Comp_Type) then
+ Set_Assignment_OK (Comp);
+ return New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Comp,
Expression =>
Get_Simple_Init_Val
(Comp_Type, Nod, Component_Size (A_Type))));
if not Has_Non_Null_Base_Init_Proc (Comp_Type)
and then not Needs_Simple_Initialization (Comp_Type)
and then not Has_Task (Comp_Type)
+ and then not Has_Default_Aspect (A_Type)
then
return New_List (Make_Null_Statement (Loc));
-- 2. The component type needs simple initialization
-- 3. Tasks are present
-- 4. The type is marked as a public entity
+ -- 5. The array type has a Default_Component_Value aspect
-- The reason for the public entity test is to deal properly with the
-- Initialize_Scalars pragma. This pragma can be set in the client and
Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Needs_Simple_Initialization (Comp_Type)
- or else Has_Task (Comp_Type);
+ or else Has_Task (Comp_Type)
+ or else Has_Default_Aspect (A_Type);
if Has_Default_Init
or else (not Restriction_Active (No_Initialize_Scalars)
Set_Is_Null_Init_Proc (Proc_Id);
else
- -- Try to build a static aggregate to initialize statically
+ -- Try to build a static aggregate to statically initialize
-- objects of the type. This can only be done for constrained
-- one-dimensional arrays with static bounds.
begin
-- If the original node of the expression was a conversion
- -- to this specific class-wide interface type then we
- -- restore the original node because we must copy the object
- -- before displacing the pointer to reference the secondary
- -- tag component. This code must be kept synchronized with
- -- the expansion done by routine Expand_Interface_Conversion
+ -- to this specific class-wide interface type then restore
+ -- the original node because we must copy the object before
+ -- displacing the pointer to reference the secondary tag
+ -- component. This code must be kept synchronized with the
+ -- expansion done by routine Expand_Interface_Conversion
if not Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Explicit_Dereference
return Result;
- -- For scalars, we must have normalize/initialize scalars case, or
- -- if the node N is an 'Invalid_Value attribute node.
+ -- Scalars with Default_Value aspect
+
+ elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
+ return
+ Convert_To (T,
+ Expression
+ (Get_Rep_Item_For_Entity
+ (First_Subtype (T), Name_Default_Value)));
+
+ -- Othersie, for scalars, we must have normalize/initialize scalars
+ -- case, or if the node N is an 'Invalid_Value attribute node.
elsif Is_Scalar_Type (T) then
pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
end if;
end;
+ -- Scalar type with Default_Value aspect requires initialization
+
+ elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
+ return True;
+
-- Cases needing simple initialization are access types, and, if pragma
-- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
-- types.
(T : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
-- Certain types need initialization even though there is no specific
- -- initialization routine. In this category are access types (which need
- -- initializing to null), packed array types whose implementation is a
- -- modular type, and all scalar types if Normalize_Scalars is set, as well
- -- as private types whose underlying type is present and meets any of these
- -- criteria. Finally, descendants of String and Wide_String also need
- -- initialization in Initialize/Normalize_Scalars mode. Consider_IS is
- -- normally True. If it is False, the Initialize_Scalars is not considered
- -- in determining whether simple initialization is needed.
+ -- initialization routine:
+ -- Access types (which need initializing to null)
+ -- All scalar types if Normalize_Scalars mode set
+ -- Descendents of standard string types if Normalize_Scalars mode set
+ -- Scalar types having a Default_Value attribute
+ -- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is
+ -- set to False, but if Consider_IS is set to True, then the cases above
+ -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
function Get_Simple_Init_Val
(T : Entity_Id;
declare
Element_Type : constant Entity_Id := Etype (Id);
- Pack : constant Entity_Id := Scope (Etype (Container));
+ Pack : constant Entity_Id := Scope (Base_Type (Typ));
Name_Init : Name_Id;
Name_Step : Name_Id;
Cond : Node_Id;
if Of_Present (I_Spec) then
- -- Id : Element_Type renames Pack.Element (Cursor);
+ -- Id : Element_Type renames Container.Element (Cursor);
+
+ -- The code below only handles containers where Element is not
+ -- a primitive operation of the container. This excludes
+ -- for now the Hi-Lite formal containers.
Renaming_Decl :=
Make_Object_Renaming_Declaration (Loc,
and then Is_Delayed_Aspect (Ritem)
then
Aitem := Aspect_Rep_Item (Ritem);
- Set_Parent (Aitem, Ritem);
- Analyze (Aitem);
+
+ -- Skip if this is an aspect with no corresponding pragma
+ -- or attribute definition node (such as Default_Value).
+
+ if Present (Aitem) then
+ Set_Parent (Aitem, Ritem);
+ Analyze (Aitem);
+ end if;
end if;
Next_Rep_Item (Ritem);
end if;
end if;
- -- Remaining process is to set/verify the representation information,
- -- in particular the size and alignment values. This processing is
- -- not required for generic types, since generic types do not play
- -- any part in code generation, and so the size and alignment values
- -- for such types are irrelevant.
+ -- Now we set/verify the representation information, in particular
+ -- the size and alignment values. This processing is not required for
+ -- generic types, since generic types do not play any part in code
+ -- generation, and so the size and alignment values for such types
+ -- are irrelevant.
if Is_Generic_Type (E) then
return Result;
Layout_Type (E);
end if;
+ -- If the type has a Defaut_Value/Default_Component_Value aspect,
+ -- this is where we analye the expression (after the type is frozen,
+ -- since in the case of Default_Value, we are analyzing with the
+ -- type itself, and we treat Default_Component_Value similarly for
+ -- the sake of uniformity.
+
+ if Is_First_Subtype (E) and then Has_Default_Aspect (E) then
+ declare
+ Nam : Name_Id;
+ Aspect : Node_Id;
+ Exp : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ if Is_Scalar_Type (E) then
+ Nam := Name_Default_Value;
+ Typ := E;
+ else
+ Nam := Name_Default_Component_Value;
+ Typ := Component_Type (E);
+ end if;
+
+ Aspect := Get_Rep_Item_For_Entity (E, Nam);
+ Exp := Expression (Aspect);
+ Analyze_And_Resolve (Exp, Typ);
+
+ if Etype (Exp) /= Any_Type then
+ if not Is_Static_Expression (Exp) then
+ Error_Msg_Name_1 := Nam;
+ Flag_Non_Static_Expr
+ ("aspect% requires static expression", Exp);
+ end if;
+ end if;
+ end;
+ end if;
+
-- End of freeze processing for type entities
end if;
to get correct Ada semantics. Note that for AE653 vThreads, the HW
overflow settings are an OS configuration issue. The instructions
below have no effect. */
-#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && (!defined (VTHREADS) || defined (__VXWORKSMILS__))
+#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS)
#if defined (__SPE__)
{
const unsigned long spefscr_mask = 0xfffffff3;
Pragma_Controlled |
Pragma_Convention |
Pragma_Debug_Policy |
- Pragma_Default_Value |
- Pragma_Default_Component_Value |
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
Pragma_Dimension |
-- that are not included in Ada 95, but still get recognized in GNAT.
Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
- Attribute_Address |
- Attribute_Aft |
- Attribute_Alignment |
- Attribute_Base |
- Attribute_Callable |
- Attribute_Constrained |
- Attribute_Count |
- Attribute_Delta |
- Attribute_Digits |
- Attribute_Emax |
- Attribute_Epsilon |
- Attribute_First |
- Attribute_First_Bit |
- Attribute_Fore |
- Attribute_Image |
- Attribute_Large |
- Attribute_Last |
- Attribute_Last_Bit |
- Attribute_Leading_Part |
- Attribute_Length |
- Attribute_Machine_Emax |
- Attribute_Machine_Emin |
- Attribute_Machine_Mantissa |
- Attribute_Machine_Overflows |
- Attribute_Machine_Radix |
- Attribute_Machine_Rounds |
- Attribute_Mantissa |
- Attribute_Pos |
- Attribute_Position |
- Attribute_Pred |
- Attribute_Range |
- Attribute_Safe_Emax |
- Attribute_Safe_Large |
- Attribute_Safe_Small |
- Attribute_Size |
- Attribute_Small |
- Attribute_Storage_Size |
- Attribute_Succ |
- Attribute_Terminated |
- Attribute_Val |
- Attribute_Value |
- Attribute_Width => True,
- others => False);
+ Attribute_Address |
+ Attribute_Aft |
+ Attribute_Alignment |
+ Attribute_Base |
+ Attribute_Callable |
+ Attribute_Constrained |
+ Attribute_Count |
+ Attribute_Delta |
+ Attribute_Digits |
+ Attribute_Emax |
+ Attribute_Epsilon |
+ Attribute_First |
+ Attribute_First_Bit |
+ Attribute_Fore |
+ Attribute_Image |
+ Attribute_Large |
+ Attribute_Last |
+ Attribute_Last_Bit |
+ Attribute_Leading_Part |
+ Attribute_Length |
+ Attribute_Machine_Emax |
+ Attribute_Machine_Emin |
+ Attribute_Machine_Mantissa |
+ Attribute_Machine_Overflows |
+ Attribute_Machine_Radix |
+ Attribute_Machine_Rounds |
+ Attribute_Mantissa |
+ Attribute_Pos |
+ Attribute_Position |
+ Attribute_Pred |
+ Attribute_Range |
+ Attribute_Safe_Emax |
+ Attribute_Safe_Large |
+ Attribute_Safe_Small |
+ Attribute_Size |
+ Attribute_Small |
+ Attribute_Storage_Size |
+ Attribute_Succ |
+ Attribute_Terminated |
+ Attribute_Val |
+ Attribute_Value |
+ Attribute_Width => True,
+ others => False);
-- The following array is the list of attributes defined in the Ada 2005
-- RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
-- but in Ada 95 they are considered to be implementation defined.
Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
- Attribute_Machine_Rounding |
- Attribute_Mod |
- Attribute_Priority |
- Attribute_Stream_Size |
- Attribute_Wide_Wide_Width => True,
- others => False);
+ Attribute_Machine_Rounding |
+ Attribute_Mod |
+ Attribute_Priority |
+ Attribute_Stream_Size |
+ Attribute_Wide_Wide_Width => True,
+ others => False);
-- The following array contains all attributes that imply a modification
-- of their prefixes or result in an access value. Such prefixes can be
Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
Attribute_Class_Array'(
- Attribute_Access |
- Attribute_Address |
- Attribute_Input |
- Attribute_Read |
- Attribute_Unchecked_Access |
- Attribute_Unrestricted_Access => True,
- others => False);
+ Attribute_Access |
+ Attribute_Address |
+ Attribute_Input |
+ Attribute_Read |
+ Attribute_Unchecked_Access |
+ Attribute_Unrestricted_Access => True,
+ others => False);
-----------------------
-- Local_Subprograms --
end if;
end Validate_Non_Static_Attribute_Function_Call;
- -----------------------------------------------
- -- Start of Processing for Analyze_Attribute --
- -----------------------------------------------
+ -- Start of processing for Analyze_Attribute
begin
-- Immediate return if unrecognized attribute (already diagnosed
end if;
end if;
- -- Deal with Ada 2005 issues
+ -- Deal with Ada 2005 attributes that are
- if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then
+ if Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005 then
Check_Restriction (No_Implementation_Attributes, N);
end if;
Eval_Fat.Copy_Sign
(P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
- -----------
- -- Delta --
- -----------
-
- when Attribute_Delta =>
- Fold_Ureal (N, Delta_Value (P_Type), True);
-
--------------
-- Definite --
--------------
Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
+ -----------
+ -- Delta --
+ -----------
+
+ when Attribute_Delta =>
+ Fold_Ureal (N, Delta_Value (P_Type), True);
+
------------
-- Denorm --
------------
if Present (CC)
and then not Error_Posted (Last_Bit (CC))
and then Static_Integer (Last_Bit (CC)) <
- Max_Machine_Scalar_Size
+ Max_Machine_Scalar_Size
then
Num_CC := Num_CC + 1;
Comps (Num_CC) := Comp;
Set_Is_Delayed_Aspect (Aspect);
end if;
- -- Aspects corresponding to pragmas with two arguments, where
- -- the first argument is a local name referring to the entity,
- -- and the second argument is the aspect definition expression
- -- which is an expression which must be delayed and analyzed.
-
- when Aspect_Default_Component_Value |
- Aspect_Default_Value =>
-
- -- Construct the pragma
-
- Aitem :=
- Make_Pragma (Loc,
- Pragma_Argument_Associations => New_List (
- New_Occurrence_Of (E, Loc),
- Relocate_Node (Expr)),
- Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Chars (Id)));
-
- -- These aspects do require delaying
-
- Delay_Required := True;
- Set_Is_Delayed_Aspect (Aspect);
-
-- Aspects corresponding to pragmas with two arguments, where
-- the first argument is a local name referring to the entity,
-- and the second argument is the aspect definition expression
Delay_Required := False;
+ -- Default_Value and Default_Component_Value aspects. These
+ -- are specially handled because they have no corresponding
+ -- pragmas or attributes.
+
+ when Aspect_Default_Value | Aspect_Default_Component_Value =>
+ Error_Msg_Name_1 := Chars (Id);
+
+ if not Is_Type (E) then
+ Error_Msg_N ("aspect% can only apply to a type", Id);
+ goto Continue;
+
+ elsif not Is_First_Subtype (E) then
+ Error_Msg_N ("aspect% cannot apply to subtype", Id);
+ goto Continue;
+
+ elsif A_Id = Aspect_Default_Value
+ and then not Is_Scalar_Type (E)
+ then
+ Error_Msg_N
+ ("aspect% can only be applied to scalar type", Id);
+ goto Continue;
+
+ elsif A_Id = Aspect_Default_Component_Value then
+ if not Is_Array_Type (E) then
+ Error_Msg_N
+ ("aspect% can only be applied to array type", Id);
+ goto Continue;
+ elsif not Is_Scalar_Type (Component_Type (E)) then
+ Error_Msg_N
+ ("aspect% requires scalar components", Id);
+ goto Continue;
+ end if;
+ end if;
+
+ Aitem := Empty;
+ Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
+ Set_Has_Default_Aspect (Base_Type (Entity (Ent)));
+
-- Aspects Pre/Post generate Precondition/Postcondition pragmas
-- with a first argument that is the expression, and a second
-- argument that is an informative message if the test fails.
Delay_Required := True;
end case;
- Set_From_Aspect_Specification (Aitem, True);
-
-- If a delay is required, we delay the freeze (not much point in
-- delaying the aspect if we don't delay the freeze!). The pragma
- -- or clause is then attached to the aspect specification which
- -- is placed in the rep item list.
+ -- or attribute clause if there is one is then attached to the
+ -- aspect specification which is placed in the rep item list.
if Delay_Required then
+ if Present (Aitem) then
+ Set_From_Aspect_Specification (Aitem, True);
+ Set_Is_Delayed_Aspect (Aitem);
+ Set_Aspect_Rep_Item (Aspect, Aitem);
+ end if;
+
Ensure_Freeze_Node (E);
- Set_Is_Delayed_Aspect (Aitem);
Set_Has_Delayed_Aspects (E);
- Set_Aspect_Rep_Item (Aspect, Aitem);
Record_Rep_Item (E, Aspect);
-- If no delay required, insert the pragma/clause in the tree
else
+ Set_From_Aspect_Specification (Aitem, True);
+
-- If this is a compilation unit, we will put the pragma in
-- the Pragmas_After list of the N_Compilation_Unit_Aux node.
end if;
end;
- <<Continue>>
- Next (Aspect);
+ <<Continue>>
+ Next (Aspect);
end loop Aspect_Loop;
end Analyze_Aspect_Specifications;
Attr : constant Name_Id := Chars (N);
Expr : constant Node_Id := Expression (N);
Id : constant Attribute_Id := Get_Attribute_Id (Attr);
- Ent : Entity_Id;
+
+ Ent : Entity_Id;
+ -- The entity of Nam after it is analyzed. In the case of an incomplete
+ -- type, this is the underlying type.
+
U_Ent : Entity_Id;
+ -- The underlying entity to which the attribute applies. Generally this
+ -- is the Underlying_Type of Ent, except in the case where the clause
+ -- applies to full view of incomplete type or private type in which case
+ -- U_Ent is just a copy of Ent.
FOnly : Boolean := False;
-- Reset to True for subtype specific attribute (Alignment, Size)
Pnam : Entity_Id;
Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
+ -- True for Read attribute, false for other attributes
function Has_Good_Profile (Subp : Entity_Id) return Boolean;
-- Return true if the entity is a subprogram with an appropriate
-- Start of processing for Analyze_Attribute_Definition_Clause
begin
+ -- The following code is a defense against recursion. Not clear that
+ -- this can happen legitimately, but perhaps some error situations
+ -- can cause it, and we did see this recursion during testing.
+
+ if Analyzed (N) then
+ return;
+ else
+ Set_Analyzed (N, True);
+ end if;
+
-- Process Ignore_Rep_Clauses option
if Ignore_Rep_Clauses then
-- legality, e.g. failing to provide a stream attribute for a
-- type may make a program illegal.
- when Attribute_External_Tag |
- Attribute_Input |
- Attribute_Output |
- Attribute_Read |
- Attribute_Storage_Pool |
- Attribute_Storage_Size |
- Attribute_Write =>
+ when Attribute_External_Tag |
+ Attribute_Input |
+ Attribute_Output |
+ Attribute_Read |
+ Attribute_Storage_Pool |
+ Attribute_Storage_Size |
+ Attribute_Write =>
null;
-- Other cases are errors ("attribute& cannot be set with
-- check till after code generation to take full advantage
-- of the annotation done by the back end. This entry is
-- only made if the address clause comes from source.
+
-- If the entity has a generic type, the check will be
-- performed in the instance if the actual type justifies
-- it, and we do not insert the clause in the table to
("size cannot be given for unconstrained array", Nam);
elsif Size /= No_Uint then
-
if VM_Target /= No_VM and then not GNAT_Mode then
-- Size clause is not handled properly on VM targets.
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:
+ -- 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;
("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.
+ -- 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;
Build_Predicate_Function (E, N);
end if;
- -- If type has delayed aspects, this is where we do the preanalysis
- -- at the freeze point, as part of the consistent visibility check.
- -- Note that this must be done after calling Build_Predicate_Function,
- -- since that call marks occurrences of the subtype name in the saved
- -- expression so that they will not cause trouble in the preanalysis.
+ -- If type has delayed aspects, this is where we do the preanalysis at
+ -- the freeze point, as part of the consistent visibility check. Note
+ -- that this must be done after calling Build_Predicate_Function or
+ -- Build_Invariant_Procedure since these subprograms fix occurrences of
+ -- the subtype name in the saved expression so that they will not cause
+ -- trouble in the preanalysis.
if Has_Delayed_Aspects (E) then
declare
if Is_Incomplete_Or_Private_Type (T)
and then No (Underlying_Type (T))
- and then Get_Pragma_Id (N) /= Pragma_Import
+ and then
+ (Nkind (N) /= N_Pragma
+ or else Get_Pragma_Id (N) /= Pragma_Import)
then
Error_Msg_N
("representation item must be after full type declaration", N);
-- Find the Element_Type in the package instance that defines the
-- container type.
- Ent := First_Entity (Scope (Typ));
+ Ent := First_Entity (Scope (Base_Type (Typ)));
while Present (Ent) loop
if Chars (Ent) = Name_Element_Type then
Set_Etype (Def_Id, Ent);
else
-- Find the Cursor type in similar fashion
- Ent := First_Entity (Scope (Typ));
+ Ent := First_Entity (Scope (Base_Type (Typ)));
while Present (Ent) loop
if Chars (Ent) = Name_Cursor then
Set_Etype (Def_Id, Ent);
Debug_Pragmas_Enabled :=
Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
- -----------------------------
- -- Default_Component_Value --
- -----------------------------
-
- when Pragma_Default_Component_Value => declare
- Arg : Node_Id;
- E : Entity_Id;
-
- begin
- GNAT_Pragma;
- Check_Arg_Count (2);
- Check_Arg_Is_Local_Name (Arg1);
-
- Arg := Get_Pragma_Arg (Arg1);
- Analyze (Arg);
-
- if Etype (Arg) = Any_Type then
- return;
- end if;
-
- if not Is_Entity_Name (Arg)
- or else not Is_Array_Type (Entity (Arg))
- then
- Error_Pragma_Arg ("pragma% requires an array type", Arg1);
- end if;
-
- Check_First_Subtype (Arg1);
-
- E := Entity (Arg);
- Check_Duplicate_Pragma (E);
-
- -- Check for rep item too early or too late, but skip this if
- -- the pragma comes from the corresponding aspect, since we do
- -- not need the checks, and more importantly, the pragma is on
- -- the rep item chain alreay, and must not be put there twice!
-
- if not From_Aspect_Specification (N) then
- if Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
- then
- return;
- end if;
- end if;
-
- -- Analyze the default value
-
- Arg := Get_Pragma_Arg (Arg2);
- Analyze_And_Resolve (Arg, Component_Type (E));
-
- if not Is_OK_Static_Expression (Arg) then
- Flag_Non_Static_Expr
- ("non-static expression not allowed for " &
- "Default_Component_Value",
- Arg2);
- raise Pragma_Exit;
- end if;
-
- -- Set the flag on the root type and then check for Rep_Item too
- -- early or too late, the latter call chains the pragma onto the
- -- Rep_Item chain.
-
- Set_Has_Default_Component_Value (Base_Type (E));
- end;
-
- -------------------
- -- Default_Value --
- -------------------
-
- when Pragma_Default_Value => declare
- Arg : Node_Id;
- E : Entity_Id;
-
- begin
- -- Error checks
-
- GNAT_Pragma;
- Check_Arg_Count (2);
- Check_Arg_Is_Local_Name (Arg1);
-
- Arg := Get_Pragma_Arg (Arg1);
- Analyze (Arg);
-
- if Etype (Arg) = Any_Type then
- return;
- end if;
-
- if not Is_Entity_Name (Arg)
- or else not Is_Scalar_Type (Entity (Arg))
- then
- Error_Pragma_Arg ("pragma% requires a scalar type", Arg1);
- end if;
-
- Check_First_Subtype (Arg1);
-
- E := Entity (Arg);
- Check_Duplicate_Pragma (E);
-
- -- Check for rep item too early or too late, but skip this if
- -- the pragma comes from the corresponding aspect, since we do
- -- not need the checks, and more importantly, the pragma is on
- -- the rep item chain alreay, and must not be put there twice!
-
- if not From_Aspect_Specification (N) then
- if Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
- then
- return;
- end if;
- end if;
-
- -- Analyze the default value. Note that we must do that after
- -- checking for Rep_Item_Too_Late since this resolution will
- -- freeze the type involved.
-
- Arg := Get_Pragma_Arg (Arg2);
- Analyze_And_Resolve (Arg, E);
-
- if not Is_OK_Static_Expression (Arg) then
- Flag_Non_Static_Expr
- ("non-static expression not allowed for Default_Value",
- Arg2);
- raise Pragma_Exit;
- end if;
-
- -- Set the flag on the root type and then check for Rep_Item too
- -- early or too late, the latter call chains the pragma onto the
- -- Rep_Item chain.
-
- Set_Has_Default_Value (Base_Type (E));
- end;
-
---------------------
-- Detect_Blocking --
---------------------
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
- Pragma_Default_Value => -1,
- Pragma_Default_Component_Value => -1,
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
-- Names of aspects for which there are no matching pragmas or attributes
-- so that they need to be included for aspect specification use.
+ Name_Default_Value : constant Name_Id := N + $;
+ Name_Default_Component_Value : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
Name_Post : constant Name_Id := N + $;
Name_Pre : constant Name_Id := N + $;
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
Name_CPU : constant Name_Id := N + $; -- Ada 12
Name_Debug : constant Name_Id := N + $; -- GNAT
- Name_Default_Value : constant Name_Id := N + $; -- GNAT
- Name_Default_Component_Value : constant Name_Id := N + $; -- GNAT
Name_Dimension : constant Name_Id := N + $; -- GNAT
Name_Elaborate : constant Name_Id := N + $; -- Ada 83
Name_Elaborate_All : constant Name_Id := N + $;
Pragma_CPP_Vtable,
Pragma_CPU,
Pragma_Debug,
- Pragma_Default_Value,
- Pragma_Default_Component_Value,
Pragma_Dimension,
Pragma_Elaborate,
Pragma_Elaborate_All,
projects / gcc.git / commitdiff