diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 41 | ||||
| -rwxr-xr-x | gcc/ada/aspects.adb | 6 | ||||
| -rwxr-xr-x | gcc/ada/aspects.ads | 199 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 45 | ||||
| -rw-r--r-- | gcc/ada/i-cstrin.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/mlib-prj.adb | 69 | ||||
| -rw-r--r-- | gcc/ada/par-ch13.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/par-prag.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/restrict.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 135 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 142 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 4 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 9 |
17 files changed, 514 insertions, 236 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fdec71f6612..c6a2ff86f88 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2011-08-02 Robert Dewar <dewar@adacore.com> + + * mlib-prj.adb, restrict.ads, sem_aggr.adb, sem_ch12.adb: Minor + reformatting. + +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 + +2011-08-02 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_Library_Attributes): For virtual library project, + inherit library kind. + +2011-08-02 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb: Add guards in calls to Matching_Static_Array_Bounds. + Minor reformatting. + +2011-08-02 Robert Dewar <dewar@adacore.com> + + * i-cstrin.ads: Updates to make Interfaces.C.Strings match RM + 2011-08-02 Yannick Moy <moy@adacore.com> * sem_aggr.adb (Resolve_Aggregate): Fix thinko. diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 3ad24698879..aafe74b1725 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -179,6 +179,8 @@ package body Aspects is 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 body Aspects is -- 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; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 773bf493cfa..64fb038a5ee 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -48,6 +48,8 @@ package Aspects is 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 @@ package Aspects is -- 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, - - Library_Unit_Aspects => Optional, - Boolean_Aspects => Optional); + (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); ----------------------------------------- -- 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); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 499db134ec8..408f3c5760a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -283,6 +283,7 @@ package body Einfo is -- 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 @@ package body Einfo is -- 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 @@ package body Einfo is -- Has_Inheritable_Invariants Flag248 -- Has_Predicates Flag250 - -- (unused) Flag39 - -- (unused) Flag151 -- (unused) Flag249 -- (unused) Flag251 -- (unused) Flag252 @@ -1226,6 +1226,18 @@ package body Einfo is 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 @@ package body Einfo is 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 @@ package body Einfo is 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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 4495f582680..6f44fd788df 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1428,6 +1428,18 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is -- 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 @@ package Einfo is 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 @@ package Einfo is 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 @@ package Einfo is 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 @@ package Einfo is 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); diff --git a/gcc/ada/i-cstrin.ads b/gcc/ada/i-cstrin.ads index bc6df774add..99f2afe7f63 100644 --- a/gcc/ada/i-cstrin.ads +++ b/gcc/ada/i-cstrin.ads @@ -45,8 +45,9 @@ package Interfaces.C.Strings is -- strict aliasing assumptions for this type. type chars_ptr is private; + pragma Preelaborable_Initialization (chars_ptr); - type chars_ptr_array is array (size_t range <>) of chars_ptr; + type chars_ptr_array is array (size_t range <>) of aliased chars_ptr; Null_Ptr : constant chars_ptr; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 4050382e1c6..656b9d4e824 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -73,26 +73,29 @@ package body MLib.Prj is -- Name_Id for "g-trasym.ads" Arguments : String_List_Access := No_Argument; - -- Used to accumulate arguments for the invocation of gnatbind and of - -- the compiler. Also used to collect the interface ALI when copying - -- the ALI files to the library directory. + -- Used to accumulate arguments for the invocation of gnatbind and of the + -- compiler. Also used to collect the interface ALI when copying the ALI + -- files to the library directory. Argument_Number : Natural := 0; -- Index of the last argument in Arguments Initial_Argument_Max : constant := 10; + -- Where does the magic constant 10 come from??? - No_Main_String : aliased String := "-n"; - No_Main : constant String_Access := No_Main_String'Access; + No_Main_String : aliased String := "-n"; + No_Main : constant String_Access := No_Main_String'Access; - Output_Switch_String : aliased String := "-o"; - Output_Switch : constant String_Access := Output_Switch_String'Access; + Output_Switch_String : aliased String := "-o"; + Output_Switch : constant String_Access := + Output_Switch_String'Access; - Compile_Switch_String : aliased String := "-c"; - Compile_Switch : constant String_Access := Compile_Switch_String'Access; + Compile_Switch_String : aliased String := "-c"; + Compile_Switch : constant String_Access := + Compile_Switch_String'Access; - No_Warning_String : aliased String := "-gnatws"; - No_Warning : constant String_Access := No_Warning_String'Access; + No_Warning_String : aliased String := "-gnatws"; + No_Warning : constant String_Access := No_Warning_String'Access; Auto_Initialize : constant String := "-a"; @@ -296,27 +299,24 @@ package body MLib.Prj is is Maximum_Size : Integer; pragma Import (C, Maximum_Size, "__gnat_link_max"); - -- Maximum number of bytes to put in an invocation of the - -- gnatbind. + -- Maximum number of bytes to put in an invocation of gnatbind Size : Integer; - -- The number of bytes for the invocation of the gnatbind + -- The number of bytes for the invocation of gnatbind Warning_For_Library : Boolean := False; - -- Set to True for the first warning about a unit missing from the - -- interface set. + -- Set True for first warning for a unit missing from the interface set Current_Proj : Project_Id; Libgnarl_Needed : Yes_No_Unknown := For_Project.Libgnarl_Needed; - -- Set to True if library needs to be linked with libgnarl + -- Set True if library needs to be linked with libgnarl Libdecgnat_Needed : Boolean := False; - -- On OpenVMS, set to True if library needs to be linked with libdecgnat + -- On OpenVMS, set True if library needs to be linked with libdecgnat Gtrasymobj_Needed : Boolean := False; - -- On OpenVMS, set to True if library needs to be linked with - -- g-trasym.obj. + -- On OpenVMS, set rue if library needs to be linked with g-trasym.obj Object_Directory_Path : constant String := Get_Name_String @@ -354,15 +354,14 @@ package body MLib.Prj is -- Initial size of Rpath, when first allocated Path_Option : String_Access := Linker_Library_Path_Option; - -- If null, Path Option is not supported. - -- Not a constant so that it can be deallocated. + -- If null, Path Option is not supported. Not a constant so that it can + -- be deallocated. First_ALI : File_Name_Type := No_File; -- Store the ALI file name of a source of the library (the first found) procedure Add_ALI_For (Source : File_Name_Type); - -- Add the name of the ALI file corresponding to Source to the - -- Arguments. + -- Add name of the ALI file corresponding to Source to the Arguments procedure Add_Rpath (Path : String); -- Add a path name to Rpath @@ -375,8 +374,8 @@ package body MLib.Prj is -- to link with -lgnarl (this is the case when there is a dependency -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file -- indicates that there is a need to link with -ldecgnat (this is the - -- case when there is a dependency on dec.ads), and set - -- Gtrasymobj_Needed if there is a dependency on g-trasym.ads. + -- case when there is a dependency on dec.ads). Set Gtrasymobj_Needed + -- if there is a dependency on g-trasym.ads. procedure Process (The_ALI : File_Name_Type); -- Check if the closure of a library unit which is or should be in the @@ -914,9 +913,9 @@ package body MLib.Prj is In_Tree.Packages.Table (Binder_Package).Decl.Arrays, In_Tree => In_Tree); - Switches : Variable_Value := Nil_Variable_Value; - Switch : String_List_Id := Nil_String; + Switches : Variable_Value := Nil_Variable_Value; + Switch : String_List_Id := Nil_String; begin if Defaults /= No_Array_Element then @@ -1180,8 +1179,7 @@ package body MLib.Prj is -- Invoke <gcc> -c b__<lib>.adb - -- Allocate Arguments, if it is the first time we see a standalone - -- library. + -- Allocate Arguments, if first time we see a standalone library if Arguments = No_Argument then Arguments := new String_List (1 .. Initial_Argument_Max); @@ -1247,8 +1245,7 @@ package body MLib.Prj is end; end if; - -- Now that all the arguments are set, compile the binder - -- generated file. + -- Now all the arguments are set, compile binder generated file Display (Gcc); Spawn @@ -1277,8 +1274,7 @@ package body MLib.Prj is Driver_Name := Name_Id (For_Project.Config.Shared_Lib_Driver); end if; - -- If attribute Library_Options was specified, add these additional - -- options. + -- If attribute Library_Options was specified, add these options Library_Options := Value_Of (Name_Library_Options, For_Project.Decl.Attributes, In_Tree); @@ -1353,7 +1349,7 @@ package body MLib.Prj is loop if Current_Proj.Object_Directory /= No_Path_Information then - -- The following code gets far too indented, I suggest some + -- The following code gets far too indented ... suggest some -- procedural abstraction here. How about making this declare -- block a named procedure??? @@ -1557,8 +1553,7 @@ package body MLib.Prj is Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory); - -- If Path Option is supported, add libgnat directory path name to - -- Rpath. + -- If Path Option supported, add libgnat directory path name to Rpath if Path_Option /= null then declare diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 55dd75fb701..099f0e44b15 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -427,9 +427,9 @@ package body Ch13 is -- 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; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 93a5be90d83..f52857bab4f 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1142,6 +1142,8 @@ begin Pragma_Controlled | Pragma_Convention | Pragma_Debug_Policy | + Pragma_Default_Value | + Pragma_Default_Component_Value | Pragma_Detect_Blocking | Pragma_Default_Storage_Pool | Pragma_Dimension | diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index a13326ca831..c491ca94f9a 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -220,10 +220,10 @@ package Restrict is -- message is posted on the node given as argument. procedure Check_Formal_Restriction (Msg : String; N : Node_Id); - -- Provides a wrappper on Error_Msg_F which prepends the special characters - -- "|~~" (error not serious, language prepended) provided the current mode - -- is formal verification and the node N comes originally from source. - -- Otherwise, does nothing. + -- Node N represents a construct not allowed in formal mode. If this is a + -- source node, then an error is issued on N (using Err_Msg_F), prepending + -- "|~~" (error not serious, language prepended). Call has no effect if + -- not in formal mode, or if N does not come originally from source. procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id); -- Tests to see if dynamic code generation (dynamically generated diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 131379f33b6..6e15379b0be 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -805,11 +805,13 @@ package body Sem_Aggr is procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id) is Comp_Expr : Node_Id; Comp_Assn : Node_Id; + begin if Level = 0 then if Nkind (Parent (Expr)) /= N_Qualified_Expression then Check_Formal_Restriction ("aggregate should be qualified", Expr); end if; + else Comp_Expr := First (Expressions (Expr)); while Present (Comp_Expr) loop diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 08a08d8f68e..81c59d5e124 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5064,10 +5064,10 @@ package body Sem_Ch12 is -- exchange views to restore the proper visiblity in the instance. declare - Typ : constant Entity_Id := Base_Type (Etype (E)); + Typ : constant Entity_Id := Base_Type (Etype (E)); -- The type of the actual - Gen_Id : Entity_Id; + Gen_Id : Entity_Id; -- The generic unit Parent_Scope : Entity_Id; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d5d7bfac18b..70625112cfc 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -982,7 +982,31 @@ package body Sem_Ch13 is -- 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 @@ package body Sem_Ch13 is 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 => diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9b68124181f..33aa6ac59c5 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7266,6 +7266,139 @@ package body Sem_Prag is 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 @@ package body Sem_Prag is 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, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index dc62ef7ab47..b1c23c135fc 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -644,8 +644,8 @@ package body Sem_Res is N_Derived_Type_Definition) and then D = Constraint (P)) - -- The constraint itself may be given by a subtype indication, - -- rather than by a more common discrete range. + -- The constraint itself may be given by a subtype indication, + -- rather than by a more common discrete range. or else (Nkind (P) = N_Subtype_Indication and then @@ -869,7 +869,7 @@ package body Sem_Res is exit when Nkind (Nod) /= N_Raise_Statement and then (Nkind (Nod) not in N_Raise_xxx_Error - or else Present (Condition (Nod))); + or else Present (Condition (Nod))); end; end if; @@ -1018,9 +1018,9 @@ package body Sem_Res is -- functions, this is never a parameterless call (RM 4.1.4(6)). if Nkind (Parent (N)) = N_Attribute_Reference - and then (Attribute_Name (Parent (N)) = Name_Address - or else Attribute_Name (Parent (N)) = Name_Code_Address - or else Attribute_Name (Parent (N)) = Name_Access) + and then (Attribute_Name (Parent (N)) = Name_Address or else + Attribute_Name (Parent (N)) = Name_Code_Address or else + Attribute_Name (Parent (N)) = Name_Access) then return False; end if; @@ -1900,9 +1900,9 @@ package body Sem_Res is -- a non-remote access-to-subprogram type. if Nkind (N) = N_Attribute_Reference - and then (Attribute_Name (N) = Name_Access - or else Attribute_Name (N) = Name_Unrestricted_Access - or else Attribute_Name (N) = Name_Unchecked_Access) + and then (Attribute_Name (N) = Name_Access or else + Attribute_Name (N) = Name_Unrestricted_Access or else + Attribute_Name (N) = Name_Unchecked_Access) and then Comes_From_Source (N) and then Is_Entity_Name (Prefix (N)) and then Is_Subprogram (Entity (Prefix (N))) @@ -1922,8 +1922,7 @@ package body Sem_Res is if Nkind (N) = N_Attribute_Reference and then Comes_From_Source (N) - and then (Is_Remote_Call_Interface (Typ) - or else Is_Remote_Types (Typ)) + and then (Is_Remote_Call_Interface (Typ) or else Is_Remote_Types (Typ)) then declare Attr : constant Attribute_Id := @@ -1970,16 +1969,16 @@ package body Sem_Res is -- perform semantic checks against the corresponding -- remote entities. - if (Attr = Attribute_Access - or else Attr = Attribute_Unchecked_Access - or else Attr = Attribute_Unrestricted_Access) + if (Attr = Attribute_Access or else + Attr = Attribute_Unchecked_Access or else + Attr = Attribute_Unrestricted_Access) and then Expander_Active and then Get_PCS_Name /= Name_No_DSA then Check_Subtype_Conformant (New_Id => Entity (Prefix (N)), Old_Id => Designated_Type - (Corresponding_Remote_Type (Typ)), + (Corresponding_Remote_Type (Typ)), Err_Loc => N); if Is_Remote then @@ -2512,6 +2511,7 @@ package body Sem_Res is -- Protected operation: retrieve operation name Subp_Name := Selector_Name (Name (N)); + else raise Program_Error; end if; @@ -2542,6 +2542,7 @@ package body Sem_Res is else Error_Msg_N ("\use -gnatf for details", N); end if; + else Wrong_Type (N, Typ); end if; @@ -2565,11 +2566,11 @@ package body Sem_Res is -- types, rather than a specific type, propagate the actual type -- downward. - if Typ = Any_Integer - or else Typ = Any_Boolean - or else Typ = Any_Modular - or else Typ = Any_Real - or else Typ = Any_Discrete + if Typ = Any_Integer or else + Typ = Any_Boolean or else + Typ = Any_Modular or else + Typ = Any_Real or else + Typ = Any_Discrete then Ctx_Type := Expr_Type; @@ -2880,13 +2881,10 @@ package body Sem_Res is -- not come from source, or this warning is off. if not Warn_On_Parameter_Order - or else - No (Parameter_Associations (N)) - or else - not Nkind_In (Original_Node (N), N_Procedure_Call_Statement, - N_Function_Call) - or else - not Comes_From_Source (N) + or else No (Parameter_Associations (N)) + or else not Nkind_In (Original_Node (N), N_Procedure_Call_Statement, + N_Function_Call) + or else not Comes_From_Source (N) then return; end if; @@ -3299,6 +3297,7 @@ package body Sem_Res is and then Ekind (F) /= E_In_Parameter then Generate_Reference (Orig_A, A, 'm'); + elsif not Is_Overloaded (A) then Generate_Reference (Orig_A, A); end if; @@ -3307,8 +3306,7 @@ package body Sem_Res is if Present (A) and then (Nkind (Parent (A)) /= N_Parameter_Association - or else - Chars (Selector_Name (Parent (A))) = Chars (F)) + or else Chars (Selector_Name (Parent (A))) = Chars (F)) then -- If style checking mode on, check match of formal name @@ -3417,8 +3415,7 @@ package body Sem_Res is and then Is_Limited_Record (Etype (F)) and then not Is_Constrained (Etype (F)) and then Expander_Active - and then - (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) + and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) then Establish_Transient_Scope (A, False); @@ -3624,7 +3621,7 @@ package body Sem_Res is if Is_Scalar_Type (A_Typ) or else (Ekind (F) = E_In_Parameter - and then not Is_Partially_Initialized_Type (A_Typ)) + and then not Is_Partially_Initialized_Type (A_Typ)) then Check_Unset_Reference (A); end if; @@ -3722,7 +3719,7 @@ package body Sem_Res is and then Has_Discriminants (F_Typ) and then Is_Constrained (F_Typ) and then (not Is_Derived_Type (F_Typ) - or else Comes_From_Source (Nam)) + or else Comes_From_Source (Nam)) then Apply_Discriminant_Check (A, F_Typ); @@ -3780,12 +3777,10 @@ package body Sem_Res is else if Is_Scalar_Type (F_Typ) then Apply_Scalar_Range_Check (A, A_Typ, F_Typ); - elsif Is_Array_Type (F_Typ) and then Ekind (F) = E_Out_Parameter then Apply_Length_Check (A, F_Typ); - else Apply_Range_Check (A, A_Typ, F_Typ); end if; @@ -4208,7 +4203,7 @@ package body Sem_Res is -- class-wide matching is not allowed. if (Is_Class_Wide_Type (Etype (Expression (E))) - or else Is_Class_Wide_Type (Etype (E))) + or else Is_Class_Wide_Type (Etype (E))) and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) then Wrong_Type (Expression (E), Etype (E)); @@ -4593,7 +4588,6 @@ package body Sem_Res is Get_First_Interp (N, Index, It); while Present (It.Typ) loop if Base_Type (It.Typ) = Base_Type (Standard_Integer) then - if Analyzed (N) then Error_Msg_N ("ambiguous operand in fixed operation", N); else @@ -4601,7 +4595,6 @@ package body Sem_Res is end if; elsif Is_Fixed_Point_Type (It.Typ) then - if Analyzed (N) then Error_Msg_N ("ambiguous operand in fixed operation", N); else @@ -5206,12 +5199,13 @@ package body Sem_Res is elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam)) and then ((Is_Array_Type (Etype (Nam)) - and then Covers (Typ, Component_Type (Etype (Nam)))) + and then Covers (Typ, Component_Type (Etype (Nam)))) or else (Is_Access_Type (Etype (Nam)) - and then Is_Array_Type (Designated_Type (Etype (Nam))) - and then - Covers (Typ, - Component_Type (Designated_Type (Etype (Nam)))))) + and then Is_Array_Type (Designated_Type (Etype (Nam))) + and then + Covers + (Typ, + Component_Type (Designated_Type (Etype (Nam)))))) then declare Index_Node : Node_Id; @@ -5873,7 +5867,7 @@ package body Sem_Res is procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is Condition : constant Node_Id := First (Expressions (N)); Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : Node_Id := Next (Then_Expr); + Else_Expr : Node_Id := Next (Then_Expr); begin Resolve (Condition, Any_Boolean); @@ -6071,9 +6065,9 @@ package body Sem_Res is elsif Ekind (E) = E_Out_Parameter and then Ada_Version = Ada_83 and then (Nkind (Parent (N)) in N_Op - or else (Nkind (Parent (N)) = N_Assignment_Statement - and then N = Expression (Parent (N))) - or else Nkind (Parent (N)) = N_Explicit_Dereference) + or else (Nkind (Parent (N)) = N_Assignment_Statement + and then N = Expression (Parent (N))) + or else Nkind (Parent (N)) = N_Explicit_Dereference) then Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); @@ -6188,9 +6182,7 @@ package body Sem_Res is begin if not Has_Discriminants (Tsk) - or else (not Is_Entity_Name (Lo) - and then - not Is_Entity_Name (Hi)) + or else (not Is_Entity_Name (Lo) and then not Is_Entity_Name (Hi)) then return Entry_Index_Type (E); @@ -6413,8 +6405,10 @@ package body Sem_Res is or else (Is_Access_Type (Etype (Nam)) and then Is_Array_Type (Designated_Type (Etype (Nam))) - and then Covers (Typ, - Component_Type (Designated_Type (Etype (Nam)))))) + and then + Covers + (Typ, + Component_Type (Designated_Type (Etype (Nam)))))) then declare Index_Node : Node_Id; @@ -6423,8 +6417,7 @@ package body Sem_Res is Index_Node := Make_Indexed_Component (Loc, Prefix => - Make_Function_Call (Loc, - Name => Relocate_Node (Entry_Name)), + Make_Function_Call (Loc, Name => Relocate_Node (Entry_Name)), Expressions => Parameter_Associations (N)); -- Since we are correcting a node classification error made by @@ -6449,6 +6442,7 @@ package body Sem_Res is declare New_Call : Node_Id; New_Actuals : List_Id; + begin New_Actuals := New_List (Obj); @@ -6654,9 +6648,9 @@ package body Sem_Res is end if; if T /= Any_Type then - if T = Any_String - or else T = Any_Composite - or else T = Any_Character + if T = Any_String or else + T = Any_Composite or else + T = Any_Character then if T = Any_Character then Ambiguous_Character (L); @@ -6701,6 +6695,7 @@ package body Sem_Res is if Is_Array_Type (T) and then Base_Type (T) /= Standard_String + and then Base_Type (Etype (L)) = Base_Type (Etype (R)) and then not Matching_Static_Array_Bounds (Etype (L), Etype (R)) then Check_Formal_Restriction @@ -6739,7 +6734,7 @@ package body Sem_Res is or else Comes_From_Source (Entity (N)) or else Ekind (Entity (N)) = E_Operator or else Is_Intrinsic_Subprogram - (Corresponding_Equality (Entity (N))) + (Corresponding_Equality (Entity (N))) then Eval_Relational_Op (N); @@ -6913,8 +6908,10 @@ package body Sem_Res is and then Covers (Typ, Component_Type (It.Typ))) or else (Is_Access_Type (It.Typ) and then Is_Array_Type (Designated_Type (It.Typ)) - and then Covers - (Typ, Component_Type (Designated_Type (It.Typ)))) + and then + Covers + (Typ, + Component_Type (Designated_Type (It.Typ)))) then if Found then It := Disambiguate (P, I1, I, Any_Type); @@ -7212,6 +7209,7 @@ package body Sem_Res is ("no modular type available in this context", N); Set_Etype (N, Any_Type); return; + elsif Is_Modular_Integer_Type (Typ) and then Etype (Left_Opnd (N)) = Universal_Integer and then Etype (Right_Opnd (N)) = Universal_Integer @@ -7231,9 +7229,14 @@ package body Sem_Res is -- In SPARK or ALFA, logical operations AND, OR and XOR for arrays are -- defined only when both operands have same static lower and higher - -- bounds. + -- bounds. Of course the types have to match, so only check if operands + -- are compatible and the node itself has no errors. if Is_Array_Type (B_Typ) + and then Nkind (N) in N_Binary_Op + and then + Base_Type (Etype (Left_Opnd (N))) + = Base_Type (Etype (Right_Opnd (N))) and then not Matching_Static_Array_Bounds (Etype (Left_Opnd (N)), Etype (Right_Opnd (N))) then @@ -7301,7 +7304,8 @@ package body Sem_Res is elsif not Is_Overloaded (R) and then - (Etype (R) = Universal_Integer or else + (Etype (R) = Universal_Integer + or else Etype (R) = Universal_Real) and then Is_Overloaded (L) then @@ -7327,7 +7331,6 @@ package body Sem_Res is and then not Is_Interface (Etype (R)) then return; - else T := Intersect_Types (L, R); end if; @@ -7560,13 +7563,14 @@ package body Sem_Res is else Error_Msg_N ("ambiguous operand for concatenation!", Arg); + Get_First_Interp (Arg, I, It); while Present (It.Nam) loop Error_Msg_Sloc := Sloc (It.Nam); if Base_Type (It.Typ) = Base_Type (Typ) or else Base_Type (It.Typ) = - Base_Type (Component_Type (Typ)) + Base_Type (Component_Type (Typ)) then Error_Msg_N -- CODEFIX ("\\possible interpretation#", Arg); @@ -9851,8 +9855,7 @@ package body Sem_Res is while Present (T2) loop if Is_Fixed_Point_Type (T2) and then Scope (Base_Type (T2)) = Scop - and then (Is_Potentially_Use_Visible (T2) - or else In_Use (T2)) + and then (Is_Potentially_Use_Visible (T2) or else In_Use (T2)) then if Present (T1) then Fixed_Point_Error; @@ -9991,9 +9994,9 @@ package body Sem_Res is -- checks that must be applied to such conversions to prevent -- out-of-scope references. - elsif - Ekind_In (Target_Comp_Base, E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + elsif Ekind_In + (Target_Comp_Base, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) and then Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) @@ -10019,6 +10022,7 @@ package body Sem_Res is "has deeper accessibility level than target", Operand); return False; end if; + else null; end if; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index dbe0814ce41..ba346c49654 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -448,6 +448,8 @@ package Snames is 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 @@ package Snames is Pragma_CPP_Vtable, Pragma_CPU, Pragma_Debug, + Pragma_Default_Value, + Pragma_Default_Component_Value, Pragma_Dimension, Pragma_Elaborate, Pragma_Elaborate_All, diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 63bfd54c95c..503c6f4366e 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1062,8 +1062,15 @@ package body Sprint is 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; |
