* [Ada] Final implementation of Default[_Component]_Value aspects
@ 2011-08-02 13:18 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2011-08-02 13:18 UTC (permalink / raw)
To: gcc-patches; +Cc: Robert Dewar
[-- Attachment #1: Type: text/plain, Size: 6286 bytes --]
This patch completes the implementation of the Default_Value and
Default_Component_Value aspects as described in AI05-0228. Note
that there is no matching pragma or attribute definition clause
for these aspects (because it is difficult to get these working
because of freezing problems resulting from resolving the aspect
expression with the type to which the aspect applies).
The following test (compiled with -gnatj60) shows error cases:
Compiling: errval.ads
1. pragma Ada_2012;
2. package Errval is
3. type R1 is new Integer with
4. Default_Value => 3; -- OK
5.
6. type R2 is new Integer with
7. Default_Value => 3,
8. Default_Value => 5; -- ERROR
|
>>> aspect "Default_Value" for "R2" previously
given at line 7
9.
10. type R3 is new R1 with
11. Default_Value => 5; -- OK
12.
13. type Rec1 is null record;
14. type R3a is new Integer with
15. Default_Value => Rec1'Size; -- ERROR
|
>>> aspect "Default_Value" requires static
expression
16.
17. type AR1 is access Integer with
18. Default_Value => null; -- ERROR
|
>>> aspect "Default_Value" can only be applied to
scalar type
19.
20. type R4b is new Integer with
21. Default_Value => M1b; -- OK
22. M1b : constant := 4;
23.
24. type R4a is new Integer with
25. Default_Value => M1a; -- ERROR
|
>>> object "M1a" cannot be used before end of its
declaration
26. M1a : constant R4a := 4;
27.
28. type R4 is new Integer with
29. Default_Value => M1; -- ERROR
|
>>> object "M1" cannot be used before end of its
declaration
30. M1 : R4 := 4;
31.
32. subtype R1S is R1 with
33. Default_Value => 4; -- ERROR
|
>>> aspect "Default_Value" cannot apply to subtype
34. V : constant:= 3;
35. package Inner is
36. type R5 is new Integer with
37. Default_Value => V; -- ERROR
|
>>> visibility of aspect for "R5" changes after
freeze point
38. R5V : R5;
|
>>> info: "R5" is frozen here, aspects evaluated at
this point
39. V : constant := 4;
40. end Inner;
41.
42. type S1 is
43. new String (1 .. 3) with
44. Default_Component_Value => 'A'; -- OK
45.
46. type S2 is
47. new String (1 .. 3) with
48. Default_Component_Value => 'A',
49. Default_Component_Value => 'B'; -- ERROR
|
>>> aspect "Default_Component_Value" for "S2"
previously given at line 48
50.
51. K : Character := '3';
52. type S3 is
53. new String (1 .. 3) with
54. Default_Component_Value => K; -- ERROR
|
>>> aspect "Default_Component_Value" requires
static expression
>>> "K" is not static constant or named number (RM
4.9(5))
55.
56. S1V : S1;
57.
58. type S3a is array (1 .. 3) of S1 with
59. Default_Component_Value => S1V; -- ERROR
|
>>> aspect "Default_Component_Value" requires
scalar components
60.
61. subtype S4 is S1 with
62. Default_Component_Value => 'X'; -- ERROR
|
>>> aspect "Default_Component_Value" cannot apply
to subtype
63.
64. C : constant Character := 'X';
65. package Inner2 is
66. type S4 is
67. new String (1 .. 4) with
68. Default_Component_Value => C; -- ERROR
|
>>> visibility of aspect for "S4" changes after
freeze point
69. VS4 : S4 := "ABCD";
|
>>> info: "S4" is frozen here, aspects evaluated at
this point
70. C : constant Character := '3';
71. end Inner2;
72. end Errval;
This test shows the aspects in action, it compiles
and executes quietly when compiled with -gnata -gnatws.
1. pragma Ada_2012;
2. procedure DefTest is
3. type R is new Integer with
4. Default_Value => 3;
5. subtype RS is R range 4 .. 10;
6.
7. type A is array (1 .. 10) of Integer
8. with Default_Component_Value => 5;
9.
10. begin
11. declare
12. RV : R;
13. begin
14. pragma Assert (RV = 3);
15. end;
16.
17. begin
18. declare
19. RVS : RS;
20. begin
21. raise Program_Error;
22. end;
23. exception
24. when Constraint_Error =>
25. null;
26. end;
27.
28. declare
29. AV : A;
30. begin
31. pragma Assert (AV (3) = 5);
32. end;
33.
34. end DefTest;
Tested on x86_64-pc-linux-gnu, committed on trunk
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
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 44191 bytes --]
Index: einfo.adb
===================================================================
--- einfo.adb (revision 177145)
+++ einfo.adb (working copy)
@@ -284,7 +284,7 @@
-- 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
@@ -408,7 +408,6 @@
-- 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
@@ -518,6 +517,7 @@
-- Is_Safe_To_Reevaluate Flag249
-- Has_Predicates Flag250
+ -- (unused) Flag151
-- (unused) Flag251
-- (unused) Flag252
-- (unused) Flag253
@@ -1227,17 +1227,10 @@
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
@@ -3687,17 +3680,13 @@
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
@@ -7379,8 +7368,7 @@
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));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 177145)
+++ einfo.ads (working copy)
@@ -462,15 +462,15 @@
-- 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
@@ -1407,10 +1407,10 @@
-- 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
@@ -1428,18 +1428,12 @@
-- 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_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_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_Discriminants (Flag5)
-- Present in all types and subtypes. For types that are allowed to have
-- discriminants (record types and subtypes, task types and subtypes,
@@ -1650,9 +1644,9 @@
-- 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
@@ -4690,7 +4684,6 @@
-- 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)
@@ -4701,7 +4694,6 @@
-- 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)
@@ -4813,6 +4805,8 @@
-- 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)
@@ -4935,7 +4929,7 @@
-- 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)
@@ -5035,7 +5029,6 @@
-- 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)
@@ -5112,7 +5105,6 @@
-- 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)
@@ -5140,7 +5132,6 @@
-- 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)
@@ -5315,7 +5306,6 @@
-- 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)
@@ -5346,7 +5336,6 @@
-- 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)
@@ -5535,6 +5524,7 @@
-- 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)
@@ -5583,7 +5573,6 @@
-- 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)
@@ -6034,8 +6023,7 @@
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;
@@ -6618,8 +6606,7 @@
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);
@@ -7311,8 +7298,7 @@
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);
@@ -7751,8 +7737,7 @@
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);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 177145)
+++ sem_prag.adb (working copy)
@@ -7352,139 +7352,6 @@
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 --
---------------------
@@ -14111,8 +13978,6 @@
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,
Index: freeze.adb
===================================================================
--- freeze.adb (revision 177130)
+++ freeze.adb (working copy)
@@ -2423,8 +2423,14 @@
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);
@@ -4018,11 +4024,11 @@
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;
@@ -4033,6 +4039,42 @@
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;
Index: exp_ch13.adb
===================================================================
--- exp_ch13.adb (revision 177005)
+++ exp_ch13.adb (working copy)
@@ -240,8 +240,14 @@
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);
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 177117)
+++ par-prag.adb (working copy)
@@ -1136,8 +1136,6 @@
Pragma_Controlled |
Pragma_Convention |
Pragma_Debug_Policy |
- Pragma_Default_Value |
- Pragma_Default_Component_Value |
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
Pragma_Dimension |
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 177140)
+++ sem_ch13.adb (working copy)
@@ -536,7 +536,7 @@
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;
@@ -984,29 +984,6 @@
-- 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
-- which is an expression that does not get analyzed.
when Aspect_Suppress |
@@ -1049,6 +1026,45 @@
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.
@@ -1218,23 +1234,27 @@
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.
@@ -1278,8 +1298,8 @@
end if;
end;
- <<Continue>>
- Next (Aspect);
+ <<Continue>>
+ Next (Aspect);
end loop Aspect_Loop;
end Analyze_Aspect_Specifications;
@@ -1333,8 +1353,16 @@
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)
@@ -1366,6 +1394,7 @@
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
@@ -1528,6 +1557,16 @@
-- 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
@@ -1558,13 +1597,13 @@
-- 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
@@ -1890,6 +1929,7 @@
-- 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
@@ -2253,7 +2293,6 @@
("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.
@@ -2443,9 +2482,10 @@
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;
@@ -2673,9 +2713,9 @@
("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;
@@ -3198,11 +3238,12 @@
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
@@ -6959,7 +7000,9 @@
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);
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 177117)
+++ snames.ads-tmpl (working copy)
@@ -137,6 +137,8 @@
-- 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 + $;
@@ -447,8 +449,6 @@
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 + $;
@@ -1554,8 +1554,6 @@
Pragma_CPP_Vtable,
Pragma_CPU,
Pragma_Debug,
- Pragma_Default_Value,
- Pragma_Default_Component_Value,
Pragma_Dimension,
Pragma_Elaborate,
Pragma_Elaborate_All,
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 177087)
+++ exp_ch3.adb (working copy)
@@ -583,12 +583,24 @@
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))));
@@ -617,6 +629,7 @@
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));
@@ -678,6 +691,7 @@
-- 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
@@ -695,7 +709,8 @@
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)
@@ -777,7 +792,7 @@
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.
@@ -4831,11 +4846,11 @@
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
@@ -6885,9 +6900,18 @@
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);
@@ -8522,6 +8546,11 @@
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.
Index: exp_ch3.ads
===================================================================
--- exp_ch3.ads (revision 176998)
+++ exp_ch3.ads (working copy)
@@ -130,14 +130,14 @@
(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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2011-08-02 13:18 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-08-02 13:18 [Ada] Final implementation of Default[_Component]_Value aspects Arnaud Charlet
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).