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 <de...@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
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,