* [Ada] Preliminary work for Default_[Component_]Value (AI 228)
@ 2011-08-02 9:42 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2011-08-02 9:42 UTC (permalink / raw)
To: gcc-patches; +Cc: Robert Dewar
[-- Attachment #1: Type: text/plain, Size: 1261 bytes --]
This is preliminary work for implementing these new aspects
and pragmas. Not yet ready for prime time.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-02 Robert Dewar <dewar@adacore.com>
* aspects.adb: New aspects Default_Value and Default_Component_Value
New format of Aspect_Names table checks for omitted entries
* aspects.ads: Remove mention of Aspect_Cancel and add documentation on
handling of boolean aspects for derived types.
New aspects Default_Value and Default_Component_Value
New format of Aspect_Names table checks for omitted entries
* einfo.ads, einfo.adb (Has_Default_Component_Value): New flag
(Has_Default_Value): New flag
(Has_Default_Component_Value): New flag
(Has_Default_Value): New flag
* par-ch13.adb (P_Aspect_Specifications): New format of Aspect_Names
table.
* par-prag.adb: New pragmas Default_Value and Default_Component_Value
* sem_ch13.adb (Analyze_Aspect_Specifications): New aspects
Default_Value and Default_Component_Value
* sem_prag.adb: New pragmas Default_Value and Default_Component_Value
New aspects Default_Value and Default_Component_Value
* snames.ads-tmpl: New pragmas Default_Value and Default_Component_Value
* sprint.adb: Print N_Aspect_Specification node when called from gdb
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 36337 bytes --]
Index: par-ch13.adb
===================================================================
--- par-ch13.adb (revision 177095)
+++ par-ch13.adb (working copy)
@@ -427,9 +427,9 @@
-- Check bad spelling
- for J in Aspect_Names'Range loop
- if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J).Nam) then
- Error_Msg_Name_1 := Aspect_Names (J).Nam;
+ for J in Aspect_Id loop
+ if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then
+ Error_Msg_Name_1 := Aspect_Names (J);
Error_Msg_SC -- CODEFIX
("\possible misspelling of%");
exit;
Index: einfo.adb
===================================================================
--- einfo.adb (revision 177092)
+++ einfo.adb (working copy)
@@ -283,6 +283,7 @@
-- Referenced_As_LHS Flag36
-- Is_Known_Non_Null Flag37
-- Can_Never_Be_Null Flag38
+ -- Has_Default_Value Flag39
-- Body_Needed_For_SAL Flag40
-- Treat_As_Volatile Flag41
@@ -406,6 +407,7 @@
-- 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
@@ -514,8 +516,6 @@
-- Has_Inheritable_Invariants Flag248
-- Has_Predicates Flag250
- -- (unused) Flag39
- -- (unused) Flag151
-- (unused) Flag249
-- (unused) Flag251
-- (unused) Flag252
@@ -1226,6 +1226,18 @@
return Flag119 (Id);
end Has_Convention_Pragma;
+ function Has_Default_Component_Value (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;
+
function Has_Delayed_Aspects (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -3663,6 +3675,18 @@
Set_Flag119 (Id, V);
end Set_Has_Convention_Pragma;
+ procedure Set_Has_Default_Component_Value (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));
+ Set_Flag39 (Id, V);
+ end Set_Has_Default_Value;
+
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -7326,6 +7350,8 @@
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_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Discriminants", Flag5 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 177053)
+++ einfo.ads (working copy)
@@ -1428,6 +1428,18 @@
-- 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_Discriminants (Flag5)
-- Present in all types and subtypes. For types that are allowed to have
-- discriminants (record types and subtypes, task types and subtypes,
@@ -3099,12 +3111,12 @@
-- interpreted as true. Currently this is set true for derived Boolean
-- types which have a convention of C, C++ or Fortran.
--- No_Pool_Assigned (Flag131) [root type only] Present in access types.
--- Set if a storage size clause applies to the variable with a static
--- expression value of zero. This flag is used to generate errors if any
--- attempt is made to allocate or free an instance of such an access
--- type. This is set only in the root type, since derived types must
--- have the same pool.
+-- No_Pool_Assigned (Flag131) [root type only]
+-- Present in access types. Set if a storage size clause applies to the
+-- variable with a static expression value of zero. This flag is used to
+-- generate errors if any attempt is made to allocate or free an instance
+-- of such an access type. This is set only in the root type, since
+-- derived types must have the same pool.
-- No_Return (Flag113)
-- Present in all entities. Always false except in the case of procedures
@@ -4902,6 +4914,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)
-- Is_Aliased (Flag15)
-- Is_Constrained (Flag12)
-- Next_Index (synth)
@@ -5001,6 +5014,7 @@
-- 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)
@@ -5077,6 +5091,7 @@
-- 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)
@@ -5103,6 +5118,8 @@
-- E_Floating_Point_Subtype
-- 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)
@@ -5114,7 +5131,6 @@
-- Safe_Emax_Value (synth)
-- Safe_First_Value (synth)
-- Safe_Last_Value (synth)
- -- Scalar_Range (Node20)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- Vax_Float (synth)
@@ -5272,12 +5288,13 @@
-- E_Modular_Integer_Type
-- E_Modular_Integer_Subtype
- -- Modulus (Uint17) (base type only)
+ -- Modulus (Uint17) (base type only)
-- Original_Array_Type (Node21)
-- Scalar_Range (Node20)
-- Static_Predicate (List25)
- -- Non_Binary_Modulus (Flag58) (base type only)
+ -- 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)
@@ -5308,6 +5325,7 @@
-- 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)
@@ -5544,6 +5562,7 @@
-- 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)
@@ -5993,6 +6012,8 @@
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_Delayed_Aspects (Id : E) return B;
function Has_Delayed_Freeze (Id : E) return B;
function Has_Discriminants (Id : E) return B;
@@ -6573,6 +6594,8 @@
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_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);
@@ -7262,6 +7285,8 @@
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_Delayed_Aspects);
pragma Inline (Has_Delayed_Freeze);
pragma Inline (Has_Discriminants);
@@ -7698,6 +7723,8 @@
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_Delayed_Aspects);
pragma Inline (Set_Has_Delayed_Freeze);
pragma Inline (Set_Has_Discriminants);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 177095)
+++ sem_prag.adb (working copy)
@@ -7266,6 +7266,139 @@
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 --
---------------------
@@ -13910,6 +14043,8 @@
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: aspects.adb
===================================================================
--- aspects.adb (revision 177027)
+++ aspects.adb (working copy)
@@ -179,6 +179,8 @@
Aspect_Atomic_Components => Aspect_Atomic_Components,
Aspect_Bit_Order => Aspect_Bit_Order,
Aspect_Component_Size => Aspect_Component_Size,
+ Aspect_Default_Component_Value => Aspect_Default_Component_Value,
+ Aspect_Default_Value => Aspect_Default_Value,
Aspect_Discard_Names => Aspect_Discard_Names,
Aspect_Dynamic_Predicate => Aspect_Predicate,
Aspect_External_Tag => Aspect_External_Tag,
@@ -289,7 +291,7 @@
-- Package initialization sets up Aspect Id hash table
begin
- for J in Aspect_Names'Range loop
- Aspect_Id_Hash_Table.Set (Aspect_Names (J).Nam, Aspect_Names (J).Asp);
+ for J in Aspect_Id loop
+ Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
end loop;
end Aspects;
Index: aspects.ads
===================================================================
--- aspects.ads (revision 177094)
+++ aspects.ads (working copy)
@@ -48,6 +48,8 @@
Aspect_Alignment,
Aspect_Bit_Order,
Aspect_Component_Size,
+ Aspect_Default_Component_Value,
+ Aspect_Default_Value,
Aspect_Dynamic_Predicate,
Aspect_External_Tag,
Aspect_Input,
@@ -157,111 +159,112 @@
-- The following array indicates what argument type is required
Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression :=
- (No_Aspect => Optional,
- Aspect_Address => Expression,
- Aspect_Alignment => Expression,
- Aspect_Bit_Order => Expression,
- Aspect_Component_Size => Expression,
- Aspect_Dynamic_Predicate => Expression,
- Aspect_External_Tag => Expression,
- Aspect_Input => Name,
- Aspect_Invariant => Expression,
- Aspect_Machine_Radix => Expression,
- Aspect_Object_Size => Expression,
- Aspect_Output => Name,
- Aspect_Post => Expression,
- Aspect_Postcondition => Expression,
- Aspect_Pre => Expression,
- Aspect_Precondition => Expression,
- Aspect_Predicate => Expression,
- Aspect_Read => Name,
- Aspect_Size => Expression,
- Aspect_Static_Predicate => Expression,
- Aspect_Storage_Pool => Name,
- Aspect_Storage_Size => Expression,
- Aspect_Stream_Size => Expression,
- Aspect_Suppress => Name,
- Aspect_Type_Invariant => Expression,
- Aspect_Unsuppress => Name,
- Aspect_Value_Size => Expression,
- Aspect_Warnings => Name,
- Aspect_Write => Name,
+ (No_Aspect => Optional,
+ Aspect_Address => Expression,
+ Aspect_Alignment => Expression,
+ Aspect_Bit_Order => Expression,
+ Aspect_Component_Size => Expression,
+ Aspect_Default_Component_Value => Expression,
+ Aspect_Default_Value => Expression,
+ Aspect_Dynamic_Predicate => Expression,
+ Aspect_External_Tag => Expression,
+ Aspect_Input => Name,
+ Aspect_Invariant => Expression,
+ Aspect_Machine_Radix => Expression,
+ Aspect_Object_Size => Expression,
+ Aspect_Output => Name,
+ Aspect_Post => Expression,
+ Aspect_Postcondition => Expression,
+ Aspect_Pre => Expression,
+ Aspect_Precondition => Expression,
+ Aspect_Predicate => Expression,
+ Aspect_Read => Name,
+ Aspect_Size => Expression,
+ Aspect_Static_Predicate => Expression,
+ Aspect_Storage_Pool => Name,
+ Aspect_Storage_Size => Expression,
+ Aspect_Stream_Size => Expression,
+ Aspect_Suppress => Name,
+ Aspect_Type_Invariant => Expression,
+ Aspect_Unsuppress => Name,
+ Aspect_Value_Size => Expression,
+ Aspect_Warnings => Name,
+ Aspect_Write => Name,
- Library_Unit_Aspects => Optional,
- Boolean_Aspects => Optional);
+ Library_Unit_Aspects => Optional,
+ Boolean_Aspects => Optional);
-----------------------------------------
-- Table Linking Names and Aspect_Id's --
-----------------------------------------
- type Aspect_Entry is record
- Nam : Name_Id;
- Asp : Aspect_Id;
- end record;
-
-- Table linking aspect names and id's
- Aspect_Names : constant array (Integer range <>) of Aspect_Entry :=
- ((Name_Ada_2005, Aspect_Ada_2005),
- (Name_Ada_2012, Aspect_Ada_2012),
- (Name_Address, Aspect_Address),
- (Name_Alignment, Aspect_Alignment),
- (Name_All_Calls_Remote, Aspect_All_Calls_Remote),
- (Name_Atomic, Aspect_Atomic),
- (Name_Atomic_Components, Aspect_Atomic_Components),
- (Name_Bit_Order, Aspect_Bit_Order),
- (Name_Compiler_Unit, Aspect_Compiler_Unit),
- (Name_Component_Size, Aspect_Component_Size),
- (Name_Discard_Names, Aspect_Discard_Names),
- (Name_Dynamic_Predicate, Aspect_Dynamic_Predicate),
- (Name_Elaborate_Body, Aspect_Elaborate_Body),
- (Name_External_Tag, Aspect_External_Tag),
- (Name_Favor_Top_Level, Aspect_Favor_Top_Level),
- (Name_Inline, Aspect_Inline),
- (Name_Inline_Always, Aspect_Inline_Always),
- (Name_Input, Aspect_Input),
- (Name_Invariant, Aspect_Invariant),
- (Name_Machine_Radix, Aspect_Machine_Radix),
- (Name_Object_Size, Aspect_Object_Size),
- (Name_Output, Aspect_Output),
- (Name_Pack, Aspect_Pack),
- (Name_Persistent_BSS, Aspect_Persistent_BSS),
- (Name_Post, Aspect_Post),
- (Name_Postcondition, Aspect_Postcondition),
- (Name_Pre, Aspect_Pre),
- (Name_Precondition, Aspect_Precondition),
- (Name_Predicate, Aspect_Predicate),
- (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization),
- (Name_Preelaborate, Aspect_Preelaborate),
- (Name_Preelaborate_05, Aspect_Preelaborate_05),
- (Name_Pure, Aspect_Pure),
- (Name_Pure_05, Aspect_Pure_05),
- (Name_Pure_Function, Aspect_Pure_Function),
- (Name_Read, Aspect_Read),
- (Name_Remote_Call_Interface, Aspect_Remote_Call_Interface),
- (Name_Remote_Types, Aspect_Remote_Types),
- (Name_Shared, Aspect_Shared),
- (Name_Shared_Passive, Aspect_Shared_Passive),
- (Name_Size, Aspect_Size),
- (Name_Static_Predicate, Aspect_Static_Predicate),
- (Name_Storage_Pool, Aspect_Storage_Pool),
- (Name_Storage_Size, Aspect_Storage_Size),
- (Name_Stream_Size, Aspect_Stream_Size),
- (Name_Suppress, Aspect_Suppress),
- (Name_Suppress_Debug_Info, Aspect_Suppress_Debug_Info),
- (Name_Type_Invariant, Aspect_Type_Invariant),
- (Name_Unchecked_Union, Aspect_Unchecked_Union),
- (Name_Universal_Aliasing, Aspect_Universal_Aliasing),
- (Name_Universal_Data, Aspect_Universal_Data),
- (Name_Unmodified, Aspect_Unmodified),
- (Name_Unreferenced, Aspect_Unreferenced),
- (Name_Unreferenced_Objects, Aspect_Unreferenced_Objects),
- (Name_Unsuppress, Aspect_Unsuppress),
- (Name_Value_Size, Aspect_Value_Size),
- (Name_Volatile, Aspect_Volatile),
- (Name_Volatile_Components, Aspect_Volatile_Components),
- (Name_Warnings, Aspect_Warnings),
- (Name_Write, Aspect_Write));
+ Aspect_Names : constant array (Aspect_Id) of Name_Id := (
+ No_Aspect => No_Name,
+ Aspect_Ada_2005 => Name_Ada_2005,
+ Aspect_Ada_2012 => Name_Ada_2012,
+ Aspect_Address => Name_Address,
+ Aspect_Alignment => Name_Alignment,
+ Aspect_All_Calls_Remote => Name_All_Calls_Remote,
+ Aspect_Atomic => Name_Atomic,
+ Aspect_Atomic_Components => Name_Atomic_Components,
+ Aspect_Bit_Order => Name_Bit_Order,
+ Aspect_Compiler_Unit => Name_Compiler_Unit,
+ Aspect_Component_Size => Name_Component_Size,
+ Aspect_Default_Value => Name_Default_Value,
+ Aspect_Default_Component_Value => Name_Default_Component_Value,
+ Aspect_Discard_Names => Name_Discard_Names,
+ Aspect_Dynamic_Predicate => Name_Dynamic_Predicate,
+ Aspect_Elaborate_Body => Name_Elaborate_Body,
+ Aspect_External_Tag => Name_External_Tag,
+ Aspect_Favor_Top_Level => Name_Favor_Top_Level,
+ Aspect_Inline => Name_Inline,
+ Aspect_Inline_Always => Name_Inline_Always,
+ Aspect_Input => Name_Input,
+ Aspect_Invariant => Name_Invariant,
+ Aspect_Machine_Radix => Name_Machine_Radix,
+ Aspect_No_Return => Name_No_Return,
+ Aspect_Object_Size => Name_Object_Size,
+ Aspect_Output => Name_Output,
+ Aspect_Pack => Name_Pack,
+ Aspect_Persistent_BSS => Name_Persistent_BSS,
+ Aspect_Post => Name_Post,
+ Aspect_Postcondition => Name_Postcondition,
+ Aspect_Pre => Name_Pre,
+ Aspect_Precondition => Name_Precondition,
+ Aspect_Predicate => Name_Predicate,
+ Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization,
+ Aspect_Preelaborate => Name_Preelaborate,
+ Aspect_Preelaborate_05 => Name_Preelaborate_05,
+ Aspect_Pure => Name_Pure,
+ Aspect_Pure_05 => Name_Pure_05,
+ Aspect_Pure_Function => Name_Pure_Function,
+ Aspect_Read => Name_Read,
+ Aspect_Remote_Call_Interface => Name_Remote_Call_Interface,
+ Aspect_Remote_Types => Name_Remote_Types,
+ Aspect_Shared => Name_Shared,
+ Aspect_Shared_Passive => Name_Shared_Passive,
+ Aspect_Size => Name_Size,
+ Aspect_Static_Predicate => Name_Static_Predicate,
+ Aspect_Storage_Pool => Name_Storage_Pool,
+ Aspect_Storage_Size => Name_Storage_Size,
+ Aspect_Stream_Size => Name_Stream_Size,
+ Aspect_Suppress => Name_Suppress,
+ Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info,
+ Aspect_Type_Invariant => Name_Type_Invariant,
+ Aspect_Unchecked_Union => Name_Unchecked_Union,
+ Aspect_Universal_Aliasing => Name_Universal_Aliasing,
+ Aspect_Universal_Data => Name_Universal_Data,
+ Aspect_Unmodified => Name_Unmodified,
+ Aspect_Unreferenced => Name_Unreferenced,
+ Aspect_Unreferenced_Objects => Name_Unreferenced_Objects,
+ Aspect_Unsuppress => Name_Unsuppress,
+ Aspect_Value_Size => Name_Value_Size,
+ Aspect_Volatile => Name_Volatile,
+ Aspect_Volatile_Components => Name_Volatile_Components,
+ Aspect_Warnings => Name_Warnings,
+ Aspect_Write => Name_Write);
function Get_Aspect_Id (Name : Name_Id) return Aspect_Id;
pragma Inline (Get_Aspect_Id);
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 177061)
+++ par-prag.adb (working copy)
@@ -1142,6 +1142,8 @@
Pragma_Controlled |
Pragma_Convention |
Pragma_Debug_Policy |
+ Pragma_Default_Value |
+ Pragma_Default_Component_Value |
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
Pragma_Dimension |
Index: sprint.adb
===================================================================
--- sprint.adb (revision 177089)
+++ sprint.adb (working copy)
@@ -1062,8 +1062,15 @@
Write_Str_Sloc (" and then ");
Sprint_Right_Opnd (Node);
+ -- Note: the following code for N_Aspect_Specification is not
+ -- normally used, since we deal with aspects as part of a
+ -- declaration, but it is here in case we deliberately try
+ -- to print an N_Aspect_Speficiation node (e.g. from GDB).
+
when N_Aspect_Specification =>
- raise Program_Error;
+ Sprint_Node (Identifier (Node));
+ Write_Str (" => ");
+ Sprint_Node (Expression (Node));
when N_Assignment_Statement =>
Write_Indent;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 177095)
+++ sem_ch13.adb (working copy)
@@ -982,8 +982,32 @@
-- 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.
+ -- 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, Eloc),
+ 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 |
Aspect_Unsuppress =>
@@ -5209,20 +5233,25 @@
when Library_Unit_Aspects =>
raise Program_Error;
- -- Aspects taking an optional boolean argument. Note that we will
- -- never be called with an empty expression, because such aspects
- -- never need to be delayed anyway.
+ -- Aspects taking an optional boolean argument. Should be impossible
+ -- since these are never delayed.
when Boolean_Aspects =>
- pragma Assert (Present (Expression (ASN)));
- T := Standard_Boolean;
+ raise Program_Error;
+ -- Default_Value and Default_Component_Value are resolved with
+ -- the entity, which is the type in question.
+
+ when Aspect_Default_Component_Value |
+ Aspect_Default_Value =>
+ T := Entity (ASN);
+
-- Aspects corresponding to attribute definition clauses
- when Aspect_Address =>
+ when Aspect_Address =>
T := RTE (RE_Address);
- when Aspect_Bit_Order =>
+ when Aspect_Bit_Order =>
T := RTE (RE_Bit_Order);
when Aspect_External_Tag =>
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 177056)
+++ snames.ads-tmpl (working copy)
@@ -448,6 +448,8 @@
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,6 +1556,8 @@
Pragma_CPP_Vtable,
Pragma_CPU,
Pragma_Debug,
+ Pragma_Default_Value,
+ Pragma_Default_Component_Value,
Pragma_Dimension,
Pragma_Elaborate,
Pragma_Elaborate_All,
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2011-08-02 9:42 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-08-02 9:42 [Ada] Preliminary work for Default_[Component_]Value (AI 228) 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).