diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/einfo.adb | 159 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 101 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 710 | ||||
| -rw-r--r-- | gcc/ada/exp_imgv.adb | 57 | ||||
| -rw-r--r-- | gcc/ada/exp_strm.adb | 138 | ||||
| -rw-r--r-- | gcc/ada/exp_tss.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_tss.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 255 | ||||
| -rw-r--r-- | gcc/ada/par-ch10.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/par-ch12.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/par-ch6.adb | 93 | ||||
| -rw-r--r-- | gcc/ada/par-ch9.adb | 126 | ||||
| -rw-r--r-- | gcc/ada/s-imgwch.adb | 76 | ||||
| -rw-r--r-- | gcc/ada/s-imgwch.ads | 24 | ||||
| -rw-r--r-- | gcc/ada/s-valwch.adb | 77 | ||||
| -rw-r--r-- | gcc/ada/s-valwch.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/s-widwch.adb | 70 | ||||
| -rw-r--r-- | gcc/ada/s-widwch.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/s-wwdcha.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/s-wwdwch.adb | 77 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 263 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.ads | 263 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 531 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 93 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 133 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 181 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 54 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 60 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 64 |
30 files changed, 2469 insertions, 1270 deletions
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 20327cb6d4b..4bd76bf29a0 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -211,7 +211,7 @@ package body Einfo is -- Obsolescent_Warning Node24 -- Task_Body_Procedure Node24 - -- Abstract_Interfaces Node24 + -- Abstract_Interfaces Elist24 -- Abstract_Interface_Alias Node25 @@ -433,15 +433,16 @@ package body Einfo is -- Has_Stream_Size_Clause Flag184 -- Is_Ada_2005 Flag185 -- Is_Interface Flag186 + -- Has_Constrained_Partial_View Flag187 + -- Has_Persistent_BSS Flag188 + -- Is_Pure_Unit_Access_Type Flag189 + -- Has_Specified_Stream_Input Flag190 + + -- Has_Specified_Stream_Output Flag191 + -- Has_Specified_Stream_Read Flag192 + -- Has_Specified_Stream_Write Flag193 + -- Is_Local_Anonymous_Access Flag194 - -- (unused) Flag187 - -- (unused) Flag188 - -- (unused) Flag189 - -- (unused) Flag190 - -- (unused) Flag191 - -- (unused) Flag192 - -- (unused) Flag193 - -- (unused) Flag194 -- (unused) Flag195 -- (unused) Flag196 -- (unused) Flag197 @@ -500,10 +501,12 @@ package body Einfo is function Abstract_Interfaces (Id : E) return L is begin - pragma Assert (Ekind (Id) = E_Record_Type - or else Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Record_Type_With_Private - or else Ekind (Id) = E_Record_Subtype_With_Private); + pragma Assert + (Ekind (Id) = E_Record_Type + or else Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Record_Type_With_Private + or else Ekind (Id) = E_Record_Subtype_With_Private + or else Ekind (Id) = E_Class_Wide_Type); return Elist24 (Id); end Abstract_Interfaces; @@ -817,7 +820,7 @@ package body Einfo is function DT_Entry_Count (Id : E) return U is begin - pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id)); + pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id)); return Uint15 (Id); end DT_Entry_Count; @@ -1104,6 +1107,12 @@ package body Einfo is return Flag68 (Implementation_Base_Type (Id)); end Has_Component_Size_Clause; + function Has_Constrained_Partial_View (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag187 (Id); + end Has_Constrained_Partial_View; + function Has_Controlled_Component (Id : E) return B is begin return Flag43 (Base_Type (Id)); @@ -1212,6 +1221,11 @@ package body Einfo is return Flag154 (Id); end Has_Per_Object_Constraint; + function Has_Persistent_BSS (Id : E) return B is + begin + return Flag188 (Id); + end Has_Persistent_BSS; + function Has_Pragma_Controlled (Id : E) return B is begin pragma Assert (Is_Access_Type (Id)); @@ -1289,6 +1303,30 @@ package body Einfo is return Flag100 (Implementation_Base_Type (Id)); end Has_Specified_Layout; + function Has_Specified_Stream_Input (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag190 (Id); + end Has_Specified_Stream_Input; + + function Has_Specified_Stream_Output (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag191 (Id); + end Has_Specified_Stream_Output; + + function Has_Specified_Stream_Read (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag192 (Id); + end Has_Specified_Stream_Read; + + function Has_Specified_Stream_Write (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag193 (Id); + end Has_Specified_Stream_Write; + function Has_Storage_Size_Clause (Id : E) return B is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); @@ -1374,6 +1412,12 @@ package body Einfo is return Flag19 (Id); end Is_Abstract; + function Is_Local_Anonymous_Access (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag194 (Id); + end Is_Local_Anonymous_Access; + function Is_Access_Constant (Id : E) return B is begin pragma Assert (Is_Access_Type (Id)); @@ -1579,11 +1623,6 @@ package body Einfo is function Is_Interface (Id : E) return B is begin - pragma Assert (Ekind (Id) = E_Record_Type - or else Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Record_Type_With_Private - or else Ekind (Id) = E_Record_Subtype_With_Private - or else Ekind (Id) = E_Class_Wide_Type); return Flag186 (Id); end Is_Interface; @@ -1654,7 +1693,6 @@ package body Einfo is function Is_Obsolescent (Id : E) return B is begin - pragma Assert (Is_Subprogram (Id)); return Flag153 (Id); end Is_Obsolescent; @@ -1718,6 +1756,12 @@ package body Einfo is return Flag44 (Id); end Is_Pure; + function Is_Pure_Unit_Access_Type (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag189 (Id); + end Is_Pure_Unit_Access_Type; + function Is_Remote_Call_Interface (Id : E) return B is begin return Flag62 (Id); @@ -2479,10 +2523,12 @@ package body Einfo is procedure Set_Abstract_Interfaces (Id : E; V : L) is begin - pragma Assert (Ekind (Id) = E_Record_Type - or else Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Record_Type_With_Private - or else Ekind (Id) = E_Record_Subtype_With_Private); + pragma Assert + (Ekind (Id) = E_Record_Type + or else Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Record_Type_With_Private + or else Ekind (Id) = E_Record_Subtype_With_Private + or else Ekind (Id) = E_Class_Wide_Type); Set_Elist24 (Id, V); end Set_Abstract_Interfaces; @@ -3094,6 +3140,12 @@ package body Einfo is Set_Flag68 (Id, V); end Set_Has_Component_Size_Clause; + procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag187 (Id, V); + end Set_Has_Constrained_Partial_View; + procedure Set_Has_Contiguous_Rep (Id : E; V : B := True) is begin Set_Flag181 (Id, V); @@ -3204,6 +3256,11 @@ package body Einfo is Set_Flag154 (Id, V); end Set_Has_Per_Object_Constraint; + procedure Set_Has_Persistent_BSS (Id : E; V : B := True) is + begin + Set_Flag188 (Id, V); + end Set_Has_Persistent_BSS; + procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id)); @@ -3282,6 +3339,30 @@ package body Einfo is Set_Flag100 (Id, V); end Set_Has_Specified_Layout; + procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag190 (Id, V); + end Set_Has_Specified_Stream_Input; + + procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag191 (Id, V); + end Set_Has_Specified_Stream_Output; + + procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag192 (Id, V); + end Set_Has_Specified_Stream_Read; + + procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag193 (Id, V); + end Set_Has_Specified_Stream_Write; + procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); @@ -3372,6 +3453,12 @@ package body Einfo is Set_Flag19 (Id, V); end Set_Is_Abstract; + procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Flag194 (Id, V); + end Set_Is_Local_Anonymous_Access; + procedure Set_Is_Access_Constant (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id)); @@ -3593,10 +3680,12 @@ package body Einfo is procedure Set_Is_Interface (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Record_Type - or else Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Record_Type_With_Private - or else Ekind (Id) = E_Record_Subtype_With_Private); + pragma Assert + (Ekind (Id) = E_Record_Type + or else Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Record_Type_With_Private + or else Ekind (Id) = E_Record_Subtype_With_Private + or else Ekind (Id) = E_Class_Wide_Type); Set_Flag186 (Id, V); end Set_Is_Interface; @@ -3668,7 +3757,6 @@ package body Einfo is procedure Set_Is_Obsolescent (Id : E; V : B := True) is begin - pragma Assert (Is_Subprogram (Id)); Set_Flag153 (Id, V); end Set_Is_Obsolescent; @@ -3733,6 +3821,12 @@ package body Einfo is Set_Flag44 (Id, V); end Set_Is_Pure; + procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Flag189 (Id, V); + end Set_Is_Pure_Unit_Access_Type; + procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True) is begin Set_Flag62 (Id, V); @@ -6353,6 +6447,7 @@ package body Einfo is W ("Has_Non_Standard_Rep", Flag75 (Id)); W ("Has_Object_Size_Clause", Flag172 (Id)); W ("Has_Per_Object_Constraint", Flag154 (Id)); + W ("Has_Persistent_BSS", Flag188 (Id)); W ("Has_Pragma_Controlled", Flag27 (Id)); W ("Has_Pragma_Elaborate_Body", Flag150 (Id)); W ("Has_Pragma_Inline", Flag157 (Id)); @@ -6367,6 +6462,10 @@ package body Einfo is W ("Has_Size_Clause", Flag29 (Id)); W ("Has_Small_Clause", Flag67 (Id)); W ("Has_Specified_Layout", Flag100 (Id)); + W ("Has_Specified_Stream_Input", Flag190 (Id)); + W ("Has_Specified_Stream_Output", Flag191 (Id)); + W ("Has_Specified_Stream_Read", Flag192 (Id)); + W ("Has_Specified_Stream_Write", Flag193 (Id)); W ("Has_Storage_Size_Clause", Flag23 (Id)); W ("Has_Stream_Size_Clause", Flag184 (Id)); W ("Has_Subprogram_Descriptor", Flag93 (Id)); @@ -6380,6 +6479,7 @@ package body Einfo is W ("In_Use", Flag8 (Id)); W ("Is_AST_Entry", Flag132 (Id)); W ("Is_Abstract", Flag19 (Id)); + W ("Is_Local_Anonymous_Access", Flag194 (Id)); W ("Is_Access_Constant", Flag69 (Id)); W ("Is_Ada_2005", Flag185 (Id)); W ("Is_Aliased", Flag15 (Id)); @@ -6442,6 +6542,7 @@ package body Einfo is W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); + W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); W ("Is_Remote_Call_Interface", Flag62 (Id)); W ("Is_Remote_Types", Flag61 (Id)); W ("Is_Renaming_Of_Object", Flag112 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8218d9c66c5..f6f87b4fdfc 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -115,7 +115,7 @@ package Einfo is -- There can only be a single statement, contained on a single line, -- not counting any pragma Assert statements. --- This single statement must either by a function call with simple, +-- This single statement must either be a function call with simple, -- single token arguments, or it must be a membership test of the form -- a in b, where a and b are single tokens. @@ -1281,6 +1281,12 @@ package Einfo is -- present for the given type. Note that this flag can be False even -- if Component_Size is non-zero (happens in the case of derived types). +-- Has_Constrained_Partial_View (Flag187) +-- Present in private type and their completions, when the private +-- type has no discriminants and the full view has discriminants with +-- defaults. In Ada 2005 heap-allocated objects of such types are not +-- constrained, and can change their discriminants with full assignment. + -- Has_Contiguous_Rep (Flag181) -- Present in enumeration types. True if the type as a representation -- clause whose entries are successive integers. @@ -1428,6 +1434,13 @@ package Einfo is -- 5. N_Range_Constraint - when the range expression uses the -- discriminant of the enclosing type. +-- Has_Persistent_BSS (Flag188) +-- Present in all entities. Set True for entities to which a valid +-- pragma Persistent_BSS applies. Note that although the pragma is +-- only meaningful for objects, we set it for all entities in a unit +-- to which the pragma applies, as well as the unit entity itself, for +-- convenience in propagating the flag to contained entities. + -- Has_Pragma_Controlled (Flag27) [implementation base type only] -- Present in access type entities. It is set if a pragma Controlled -- applies to the access type. @@ -1523,6 +1536,16 @@ package Einfo is -- representation clause, and thus is not inherited by a derived type. -- This flag is always False for non-record types. +-- Has_Specified_Stream_Input (Flag190) +-- Has_Specified_Stream_Output (Flag191) +-- Has_Specified_Stream_Read (Flag192) +-- Has_Specified_Stream_Write (Flag193) +-- Present in all type and subtype entities. Set for a given view if the +-- corresponding stream-oriented attribute has been defined by an +-- attribute definition clause. When such a clause occurs, a TSS is set +-- on the underlying full view; the flags are used to track visibility of +-- the attribute definition clause for partial or incomplete views. + -- Has_Storage_Size_Clause (Flag23) [implementation base type only] -- Present in task types and access types. It is set if a Storage_Size -- clause is present for the type. Used to prevent multiple clauses for @@ -1608,10 +1631,10 @@ package Einfo is -- Implementation_Base_Type (synthesized) -- Applies to all types. Similar to Base_Type, but never returns a -- private type when applied to a non-private type. Instead in this --- case, it always returns the Representation_Type of the base type --- in this case, so that we still have a concrete type. Note: it is --- allowed to apply Implementation_Base_Type to other than a type, --- in which case it simply returns the entity unchanged. +-- case, it always returns the Underlying_Type of the base type, so that +-- we still have a concrete type. Note: it is allowed to apply +-- Implementation_Base_Type to other than a type, in which case it +-- simply returns the entity unchanged. -- In_Package_Body (Flag48) -- Set on the entity that denotes the package (the defining occurrence @@ -1662,6 +1685,14 @@ package Einfo is -- Present in all types, and also for functions and procedures. Set -- for abstract types and abstract subprograms. +-- Is_Local_Anonymous_Access (Flag194) +-- Present in access types. Set for an anonymous access type to indicate +-- that the type is created for a record component with an access +-- definition, an array component, or a stand-alone object. Such +-- anonymous types have an accessibility level equal to that of the +-- declaration in which they appear, unlike the anonymous access types +-- that are created for access parameters and access discriminants. + -- Is_Access_Constant (Flag69) -- Present in access types and subtypes. Indicates that the keyword -- constant was present in the access type definition. @@ -1981,8 +2012,10 @@ package Einfo is -- Is_Internal (Flag17) -- Present in all entities. Set to indicate an entity created during --- semantic processing (e.g. an implicit type). Need more documentation --- on this one! ??? +-- semantic processing (e.g. an implicit type, or a temporary). The +-- only current use of this flag is to indicate that temporaries +-- generated for the result of an inlined function call need not be +-- initialized, even when scalars are initialized or normalized. -- Is_Interrupt_Handler (Flag89) -- Present in procedures. Set if a pragma Interrupt_Handler applies @@ -2124,8 +2157,8 @@ package Einfo is -- including generic formal parameters. -- Is_Obsolescent (Flag153) --- Present in subprogram entities. Set if a valid pragma Obsolescent --- applies to the subprogram. +-- Present in all entities. Set only for subprograms when a valid pragma +-- Obsolescent applies to the subprogram. -- Is_Optional_Parameter (Flag134) -- Present in parameter entities. Set if the parameter is specified as @@ -2252,6 +2285,11 @@ package Einfo is -- resulting from assignment to out parameters, or to objects designated -- by access parameters). +-- Is_Pure_Unit_Access_Type (Flag189) +-- Present in access type and subtype entities. Set if the type or +-- subtype appears in a pure unit. Used to give an error message at +-- freeze time if the access type has a storage pool. + -- Is_Real_Type (synthesized) -- Applies to all entities, true for real types and subtypes @@ -3933,7 +3971,7 @@ package Einfo is -- For each enumeration value defined in Entity_Kind we list all the -- attributes defined in Einfo which can legally be applied to an entity -- of that kind. The implementation of the attribute functions (and for - -- non-synthesized attributes, or the corresponding set procedures) are + -- non-synthetized attributes, of the corresponding set procedures) are -- in the Einfo body. -- The following attributes apply to all entities @@ -3958,6 +3996,7 @@ package Einfo is -- Has_Fully_Qualified_Name (Flag173) -- Has_Gigi_Rep_Item (Flag82) -- Has_Homonym (Flag56) + -- Has_Persistent_BSS (Flag188) -- Has_Pragma_Elaborate_Body (Flag150) -- Has_Pragma_Inline (Flag157) -- Has_Pragma_Unreferenced (Flag180) @@ -3987,6 +4026,7 @@ package Einfo is -- Is_Known_Valid (Flag170) -- Is_Limited_Composite (Flag106) -- Is_Limited_Record (Flag25) + -- Is_Obsolescent (Flag153) -- Is_Package_Body_Entity (Flag160) -- Is_Packed_Array_Type (Flag138) -- Is_Potentially_Use_Visible (Flag9) @@ -4037,12 +4077,17 @@ package Einfo is -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) (base type only) -- Has_Complex_Representation (Flag140) (base type only) + -- Has_Constrained_Partial_View (Flag187) -- Has_Discriminants (Flag5) -- Has_Non_Standard_Rep (Flag75) (base type only) -- Has_Object_Size_Clause (Flag172) -- Has_Primitive_Operations (Flag120) (base type only) -- Has_Size_Clause (Flag29) -- Has_Specified_Layout (Flag100) (base type only) + -- Has_Specified_Stream_Input (Flag190) + -- Has_Specified_Stream_Output (Flag191) + -- Has_Specified_Stream_Read (Flag192) + -- Has_Specified_Stream_Write (Flag193) -- Has_Task (Flag30) (base type only) -- Has_Unchecked_Union (Flag123) (base type only) -- Has_Volatile_Components (Flag87) (base type only) @@ -4110,7 +4155,9 @@ package Einfo is -- Associated_Final_Chain (Node23) -- Has_Pragma_Controlled (Flag27) (base type only) -- Has_Storage_Size_Clause (Flag23) (base type only) + -- Is_Local_Anonymous_Access (Flag194) -- Is_Access_Constant (Flag69) + -- Is_Pure_Unit_Access_Type (Flag189) -- No_Pool_Assigned (Flag131) (base type only) -- No_Strict_Aliasing (Flag136) (base type only) -- (plus type attributes) @@ -4376,7 +4423,6 @@ package Einfo is -- Is_Instantiated (Flag126) (generic case only) -- Is_Intrinsic_Subprogram (Flag64) -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) - -- Is_Obsolescent (Flag153) -- Is_Overriding_Operation (Flag39) (non-generic case only) -- Is_Private_Descendant (Flag53) -- Is_Pure (Flag44) @@ -4624,7 +4670,6 @@ package Einfo is -- Is_Intrinsic_Subprogram (Flag64) -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) -- Is_Null_Init_Proc (Flag178) - -- Is_Obsolescent (Flag153) -- Is_Overriding_Operation (Flag39) (non-generic case only) -- Is_Private_Descendant (Flag53) -- Is_Pure (Flag44) @@ -5142,6 +5187,7 @@ package Einfo is function Has_Completion_In_Body (Id : E) return B; function Has_Complex_Representation (Id : E) return B; function Has_Component_Size_Clause (Id : E) return B; + function Has_Constrained_Partial_View (Id : E) return B; function Has_Contiguous_Rep (Id : E) return B; function Has_Controlled_Component (Id : E) return B; function Has_Controlling_Result (Id : E) return B; @@ -5163,6 +5209,7 @@ package Einfo is function Has_Non_Standard_Rep (Id : E) return B; function Has_Object_Size_Clause (Id : E) return B; function Has_Per_Object_Constraint (Id : E) return B; + function Has_Persistent_BSS (Id : E) return B; function Has_Pragma_Controlled (Id : E) return B; function Has_Pragma_Elaborate_Body (Id : E) return B; function Has_Pragma_Inline (Id : E) return B; @@ -5176,6 +5223,10 @@ package Einfo is function Has_Size_Clause (Id : E) return B; function Has_Small_Clause (Id : E) return B; function Has_Specified_Layout (Id : E) return B; + function Has_Specified_Stream_Input (Id : E) return B; + function Has_Specified_Stream_Output (Id : E) return B; + function Has_Specified_Stream_Read (Id : E) return B; + function Has_Specified_Stream_Write (Id : E) return B; function Has_Storage_Size_Clause (Id : E) return B; function Has_Stream_Size_Clause (Id : E) return B; function Has_Subprogram_Descriptor (Id : E) return B; @@ -5193,6 +5244,7 @@ package Einfo is function Interface_Name (Id : E) return N; function Is_AST_Entry (Id : E) return B; function Is_Abstract (Id : E) return B; + function Is_Local_Anonymous_Access (Id : E) return B; function Is_Access_Constant (Id : E) return B; function Is_Ada_2005 (Id : E) return B; function Is_Aliased (Id : E) return B; @@ -5249,6 +5301,7 @@ package Einfo is function Is_Private_Descendant (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; + function Is_Pure_Unit_Access_Type (Id : E) return B; function Is_Remote_Call_Interface (Id : E) return B; function Is_Remote_Types (Id : E) return B; function Is_Renaming_Of_Object (Id : E) return B; @@ -5621,6 +5674,7 @@ package Einfo is procedure Set_Has_Completion_In_Body (Id : E; V : B := True); procedure Set_Has_Complex_Representation (Id : E; V : B := True); procedure Set_Has_Component_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True); procedure Set_Has_Contiguous_Rep (Id : E; V : B := True); procedure Set_Has_Controlled_Component (Id : E; V : B := True); procedure Set_Has_Controlling_Result (Id : E; V : B := True); @@ -5641,6 +5695,7 @@ package Einfo is procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True); procedure Set_Has_Object_Size_Clause (Id : E; V : B := True); procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True); + procedure Set_Has_Persistent_BSS (Id : E; V : B := True); procedure Set_Has_Pragma_Controlled (Id : E; V : B := True); procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True); procedure Set_Has_Pragma_Inline (Id : E; V : B := True); @@ -5655,6 +5710,10 @@ package Einfo is procedure Set_Has_Size_Clause (Id : E; V : B := True); procedure Set_Has_Small_Clause (Id : E; V : B := True); procedure Set_Has_Specified_Layout (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True); procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True); procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True); procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True); @@ -5672,6 +5731,7 @@ package Einfo is procedure Set_Interface_Name (Id : E; V : N); procedure Set_Is_AST_Entry (Id : E; V : B := True); procedure Set_Is_Abstract (Id : E; V : B := True); + procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True); procedure Set_Is_Access_Constant (Id : E; V : B := True); procedure Set_Is_Ada_2005 (Id : E; V : B := True); procedure Set_Is_Aliased (Id : E; V : B := True); @@ -5734,6 +5794,7 @@ package Einfo is procedure Set_Is_Private_Descendant (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); + procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); procedure Set_Is_Remote_Types (Id : E; V : B := True); procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True); @@ -6155,6 +6216,7 @@ package Einfo is pragma Inline (Has_Completion_In_Body); pragma Inline (Has_Complex_Representation); pragma Inline (Has_Component_Size_Clause); + pragma Inline (Has_Constrained_Partial_View); pragma Inline (Has_Contiguous_Rep); pragma Inline (Has_Controlled_Component); pragma Inline (Has_Controlling_Result); @@ -6175,6 +6237,7 @@ package Einfo is pragma Inline (Has_Non_Standard_Rep); pragma Inline (Has_Object_Size_Clause); pragma Inline (Has_Per_Object_Constraint); + pragma Inline (Has_Persistent_BSS); pragma Inline (Has_Pragma_Controlled); pragma Inline (Has_Pragma_Elaborate_Body); pragma Inline (Has_Pragma_Inline); @@ -6189,6 +6252,10 @@ package Einfo is pragma Inline (Has_Size_Clause); pragma Inline (Has_Small_Clause); pragma Inline (Has_Specified_Layout); + pragma Inline (Has_Specified_Stream_Input); + pragma Inline (Has_Specified_Stream_Output); + pragma Inline (Has_Specified_Stream_Read); + pragma Inline (Has_Specified_Stream_Write); pragma Inline (Has_Storage_Size_Clause); pragma Inline (Has_Stream_Size_Clause); pragma Inline (Has_Subprogram_Descriptor); @@ -6206,6 +6273,7 @@ package Einfo is pragma Inline (Interface_Name); pragma Inline (Is_AST_Entry); pragma Inline (Is_Abstract); + pragma Inline (Is_Local_Anonymous_Access); pragma Inline (Is_Access_Constant); pragma Inline (Is_Ada_2005); pragma Inline (Is_Access_Type); @@ -6296,6 +6364,7 @@ package Einfo is pragma Inline (Is_Protected_Type); pragma Inline (Is_Public); pragma Inline (Is_Pure); + pragma Inline (Is_Pure_Unit_Access_Type); pragma Inline (Is_Real_Type); pragma Inline (Is_Record_Type); pragma Inline (Is_Remote_Call_Interface); @@ -6506,6 +6575,7 @@ package Einfo is pragma Inline (Set_Has_Completion_In_Body); pragma Inline (Set_Has_Complex_Representation); pragma Inline (Set_Has_Component_Size_Clause); + pragma Inline (Set_Has_Constrained_Partial_View); pragma Inline (Set_Has_Contiguous_Rep); pragma Inline (Set_Has_Controlled_Component); pragma Inline (Set_Has_Controlling_Result); @@ -6526,6 +6596,7 @@ package Einfo is pragma Inline (Set_Has_Non_Standard_Rep); pragma Inline (Set_Has_Object_Size_Clause); pragma Inline (Set_Has_Per_Object_Constraint); + pragma Inline (Set_Has_Persistent_BSS); pragma Inline (Set_Has_Pragma_Controlled); pragma Inline (Set_Has_Pragma_Elaborate_Body); pragma Inline (Set_Has_Pragma_Inline); @@ -6540,6 +6611,10 @@ package Einfo is pragma Inline (Set_Has_Size_Clause); pragma Inline (Set_Has_Small_Clause); pragma Inline (Set_Has_Specified_Layout); + pragma Inline (Set_Has_Specified_Stream_Input); + pragma Inline (Set_Has_Specified_Stream_Output); + pragma Inline (Set_Has_Specified_Stream_Read); + pragma Inline (Set_Has_Specified_Stream_Write); pragma Inline (Set_Has_Storage_Size_Clause); pragma Inline (Set_Has_Subprogram_Descriptor); pragma Inline (Set_Has_Task); @@ -6556,6 +6631,7 @@ package Einfo is pragma Inline (Set_Interface_Name); pragma Inline (Set_Is_AST_Entry); pragma Inline (Set_Is_Abstract); + pragma Inline (Set_Is_Local_Anonymous_Access); pragma Inline (Set_Is_Access_Constant); pragma Inline (Set_Is_Ada_2005); pragma Inline (Set_Is_Aliased); @@ -6618,6 +6694,7 @@ package Einfo is pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); + pragma Inline (Set_Is_Pure_Unit_Access_Type); pragma Inline (Set_Is_Remote_Call_Interface); pragma Inline (Set_Is_Remote_Types); pragma Inline (Set_Is_Renaming_Of_Object); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 05c886a5be1..c60415f8554 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,7 +46,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; -with Sem_Ch6; +with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch11; use Sem_Ch11; with Sem_Elab; use Sem_Elab; @@ -131,6 +131,30 @@ package body Exp_Ch9 is -- of the range of each entry family. A single array with that size is -- allocated for each concurrent object of the type. + function Build_Wrapper_Body + (Loc : Source_Ptr; + Proc_Nam : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id; + -- Ada 2005 (AI-345): Build the body that wraps a primitive operation + -- associated with a protected or task type. This is required to implement + -- dispatching calls through interfaces. Proc_Nam is the entry name to be + -- wrapped, Obj_Typ is the type of the newly added formal parameter to + -- handle object notation, Formals are the original entry formals that will + -- be explicitly replicated. + + function Build_Wrapper_Spec + (Loc : Source_Ptr; + Proc_Nam : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id; + -- Ada 2005 (AI-345): Build the specification of a primitive operation + -- associated with a protected or task type. This is required implement + -- dispatching calls through interfaces. Proc_Nam is the entry name to be + -- wrapped, Obj_Typ is the type of the newly added formal parameter to + -- handle object notation, Formals are the original entry formals that will + -- be explicitly replicated. + function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; -- Build the function that translates the entry index in the call -- (which depends on the size of entry families) into an index into the @@ -850,7 +874,7 @@ package body Exp_Ch9 is Cdecls : List_Id; begin - Set_Corresponding_Record_Type (Ctyp, Rec_Ent); + Set_Corresponding_Record_Type (Ctyp, Rec_Ent); Set_Ekind (Rec_Ent, E_Record_Type); Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); Set_Is_Concurrent_Record_Type (Rec_Ent, True); @@ -895,9 +919,11 @@ package body Exp_Ch9 is end if; -- Now we can construct the record type declaration. Note that this - -- record is limited, reflecting the underlying limitedness of the - -- task or protected object that it represents, and ensuring for - -- example that it is properly passed by reference. + -- record is "limited tagged". It is "limited" to reflect the underlying + -- limitedness of the task or protected object that it represents, and + -- ensuring for example that it is properly passed by reference. It is + -- "tagged" to give support to dispatching calls through interfaces (Ada + -- 2005: AI-345) return Make_Full_Type_Declaration (Loc, @@ -908,6 +934,7 @@ package body Exp_Ch9 is Component_List => Make_Component_List (Loc, Component_Items => Cdecls), + Tagged_Present => Ada_Version >= Ada_05, Limited_Present => True)); end Build_Corresponding_Record; @@ -971,6 +998,394 @@ package body Exp_Ch9 is return Ecount; end Build_Entry_Count_Expression; + ------------------------------ + -- Build_Wrapper_Body -- + ------------------------------ + + function Build_Wrapper_Body + (Loc : Source_Ptr; + Proc_Nam : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id + is + Actuals : List_Id := No_List; + Body_Spec : Node_Id; + Conv_Id : Node_Id; + First_Formal : Node_Id; + Formal : Node_Id; + + begin + Body_Spec := Build_Wrapper_Spec (Loc, Proc_Nam, Obj_Typ, Formals); + + -- If we did not generate the specification do have nothing else to do + + if Body_Spec = Empty then + return Empty; + end if; + + -- Map formals to actuals. Use the list built for the wrapper spec, + -- skipping the object notation parameter. + + First_Formal := First (Parameter_Specifications (Body_Spec)); + + Formal := First_Formal; + Next (Formal); + + if Present (Formal) then + Actuals := New_List; + + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, Chars => + Chars (Defining_Identifier (Formal)))); + + Next (Formal); + end loop; + end if; + + -- An access-to-variable first parameter will require an explicit + -- dereference in the unchecked conversion. This case occurs when + -- a protected entry wrapper must override an interface-level + -- procedure with interface access as first parameter. + + -- SubprgName (O.all).Proc_Nam (Formal_1 .. Formal_N) + + if Nkind (Parameter_Type (First_Formal)) = N_Access_Definition then + Conv_Id := + Make_Explicit_Dereference (Loc, + Prefix => + Make_Identifier (Loc, Chars => Name_uO)); + else + Conv_Id := + Make_Identifier (Loc, Chars => Name_uO); + end if; + + if Ekind (Proc_Nam) = E_Function then + return + Make_Subprogram_Body (Loc, + Specification => Body_Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_List ( + Make_Return_Statement (Loc, + Make_Function_Call (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + Corresponding_Concurrent_Type (Obj_Typ), + Conv_Id), + Selector_Name => + New_Reference_To (Proc_Nam, Loc)), + Parameter_Associations => Actuals))))); + else + return + Make_Subprogram_Body (Loc, + Specification => Body_Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + Corresponding_Concurrent_Type (Obj_Typ), + Conv_Id), + Selector_Name => + New_Reference_To (Proc_Nam, Loc)), + Parameter_Associations => Actuals)))); + end if; + end Build_Wrapper_Body; + + ------------------------ + -- Build_Wrapper_Spec -- + ------------------------ + + function Build_Wrapper_Spec + (Loc : Source_Ptr; + Proc_Nam : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id + is + New_Name_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Proc_Nam)); + + First_Param : Node_Id := Empty; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id := No_Elmt; + New_Formals : List_Id; + Obj_Param : Node_Id; + Obj_Param_Typ : Node_Id; + Iface_Prim_Op : Entity_Id; + Iface_Prim_Op_Elmt : Elmt_Id; + + function Overriding_Possible + (Iface_Prim_Op : Entity_Id; + Proc_Nam : Entity_Id) return Boolean; + -- Determine whether a primitive operation can be overriden by the + -- wrapper. Iface_Prim_Op is the candidate primitive operation of an + -- abstract interface type, Proc_Nam is the generated entry wrapper. + + function Replicate_Entry_Formals + (Loc : Source_Ptr; + Formals : List_Id) return List_Id; + -- An explicit parameter replication is required due to the + -- Is_Entry_Formal flag being set for all the formals. The explicit + -- replication removes the flag that would otherwise cause a different + -- path of analysis. + + ------------------------- + -- Overriding_Possible -- + ------------------------- + + function Overriding_Possible + (Iface_Prim_Op : Entity_Id; + Proc_Nam : Entity_Id) return Boolean + is + Prim_Op_Spec : constant Node_Id := Parent (Iface_Prim_Op); + Proc_Spec : constant Node_Id := Parent (Proc_Nam); + + Is_Access_To_Variable : Boolean; + Is_Out_Present : Boolean; + + function Type_Conformant_Parameters + (Prim_Op_Param_Specs : List_Id; + Proc_Param_Specs : List_Id) return Boolean; + -- Determine whether the parameters of the generated entry wrapper + -- and those of a primitive operation are type conformant. During + -- this check, the first parameter of the primitive operation is + -- always skipped. + + -------------------------------- + -- Type_Conformant_Parameters -- + -------------------------------- + + function Type_Conformant_Parameters + (Prim_Op_Param_Specs : List_Id; + Proc_Param_Specs : List_Id) return Boolean + is + Prim_Op_Param : Node_Id; + Proc_Param : Node_Id; + + begin + -- Skip the first parameter of the primitive operation + + Prim_Op_Param := Next (First (Prim_Op_Param_Specs)); + Proc_Param := First (Proc_Param_Specs); + while Present (Prim_Op_Param) + and then Present (Proc_Param) + loop + -- The two parameters must be mode conformant and have + -- the exact same types. + + if Out_Present (Prim_Op_Param) /= Out_Present (Proc_Param) + or else In_Present (Prim_Op_Param) /= In_Present (Proc_Param) + or else Etype (Parameter_Type (Prim_Op_Param)) /= + Etype (Parameter_Type (Proc_Param)) + then + return False; + end if; + + Next (Prim_Op_Param); + Next (Proc_Param); + end loop; + + -- One of the lists is longer than the other + + if Present (Prim_Op_Param) or else Present (Proc_Param) then + return False; + end if; + + return True; + end Type_Conformant_Parameters; + + -- Start of processing for Overriding_Possible + + begin + if Chars (Iface_Prim_Op) /= Chars (Proc_Nam) then + return False; + end if; + + -- Special check for protected procedures: If an inherited subprogram + -- is implemented by a protected procedure or an entry, then the + -- first parameter of the inherited subprogram shall be of mode OUT + -- or IN OUT, or an access-to-variable parameter. + + if Ekind (Iface_Prim_Op) = E_Procedure then + + Is_Out_Present := + Present (Parameter_Specifications (Prim_Op_Spec)) + and then + Out_Present (First (Parameter_Specifications (Prim_Op_Spec))); + + Is_Access_To_Variable := + Present (Parameter_Specifications (Prim_Op_Spec)) + and then + Nkind (Parameter_Type + (First + (Parameter_Specifications (Prim_Op_Spec)))) + = N_Access_Definition; + + if not Is_Out_Present + and then not Is_Access_To_Variable + then + return False; + end if; + end if; + + return Type_Conformant_Parameters ( + Parameter_Specifications (Prim_Op_Spec), + Parameter_Specifications (Proc_Spec)); + + end Overriding_Possible; + + ----------------------------- + -- Replicate_Entry_Formals -- + ----------------------------- + + function Replicate_Entry_Formals + (Loc : Source_Ptr; + Formals : List_Id) return List_Id + is + New_Formals : constant List_Id := New_List; + Formal : Node_Id; + + begin + Formal := First (Formals); + + if Present (Formal) then + while Present (Formal) loop + + -- Create an explicit copy of the entry parameter + + Append_To (New_Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Formal))), + In_Present => In_Present (Formal), + Out_Present => Out_Present (Formal), + Parameter_Type => New_Reference_To (Etype ( + Parameter_Type (Formal)), Loc))); + + Next (Formal); + end loop; + end if; + + return New_Formals; + end Replicate_Entry_Formals; + + -- Start of processing for Build_Wrapper_Spec + + begin + -- The mode is determined by the first parameter of the interface-level + -- procedure that the current entry is trying to override. + + pragma Assert (Present (Abstract_Interfaces + (Corresponding_Record_Type (Scope (Proc_Nam))))); + + Iface_Elmt := + First_Elmt (Abstract_Interfaces + (Corresponding_Record_Type (Scope (Proc_Nam)))); + + -- We must examine all the protected operations of the implemented + -- interfaces in order to discover a possible overriding candidate. + + Examine_Interfaces : while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + if Present (Primitive_Operations (Iface)) then + Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); + + while Present (Iface_Prim_Op_Elmt) loop + Iface_Prim_Op := Node (Iface_Prim_Op_Elmt); + + -- The current primitive operation can be overriden by the + -- generated entry wrapper. + + if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then + First_Param := + First (Parameter_Specifications (Parent (Iface_Prim_Op))); + + exit Examine_Interfaces; + end if; + + Next_Elmt (Iface_Prim_Op_Elmt); + end loop; + end if; + + Next_Elmt (Iface_Elmt); + end loop Examine_Interfaces; + + -- Return if no interface primitive can be overriden + + if not Present (First_Param) then + return Empty; + end if; + + New_Formals := Replicate_Entry_Formals (Loc, Formals); + + -- ??? Certain source packages contain protected or task types that do + -- not implement any interfaces and are compiled with the -gnat05 + -- switch. In this case, a default first parameter is created. + + if Present (First_Param) then + if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then + Obj_Param_Typ := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To (Obj_Typ, Loc)); + else + Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc); + end if; + + Obj_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => In_Present (First_Param), + Out_Present => Out_Present (First_Param), + Parameter_Type => Obj_Param_Typ); + + else + Obj_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Obj_Typ, Loc)); + end if; + + Prepend_To (New_Formals, Obj_Param); + + -- Minimum decoration needed to catch the entity in + -- Sem_Ch6.Override_Dispatching_Operation + + if Ekind (Proc_Nam) = E_Procedure + or else Ekind (Proc_Nam) = E_Entry + then + Set_Ekind (New_Name_Id, E_Procedure); + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => New_Name_Id, + Parameter_Specifications => New_Formals); + + else pragma Assert (Ekind (Proc_Nam) = E_Function); + Set_Ekind (New_Name_Id, E_Function); + return + Make_Function_Specification (Loc, + Defining_Unit_Name => New_Name_Id, + Parameter_Specifications => New_Formals, + Subtype_Mark => New_Copy (Subtype_Mark (Parent (Proc_Nam)))); + end if; + end Build_Wrapper_Spec; + --------------------------- -- Build_Find_Body_Index -- --------------------------- @@ -1513,7 +1928,14 @@ package body Exp_Ch9 is if Unprotected then Append_Char := 'N'; else - Append_Char := 'P'; + -- Ada 2005 (AI-345): The protected version no longer uses 'P' + -- as suffix in order to make it a primitive operation + + if Ada_Version >= Ada_05 then + Append_Char := ' '; + else + Append_Char := 'P'; + end if; end if; New_Id := @@ -4836,6 +5258,7 @@ package body Exp_Ch9 is -- the state of the protected object. procedure Expand_N_Protected_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); Pid : constant Entity_Id := Corresponding_Spec (N); Has_Entries : Boolean := False; Op_Decl : Node_Id; @@ -4985,8 +5408,70 @@ package body Exp_Ch9 is then New_Op_Body := Build_Find_Body_Index (Pid); Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; Analyze (New_Op_Body); end if; + + -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies + -- after the protected body. At this point the entry specs have been + -- created, frozen and included in the dispatch table for the + -- protected type. + + pragma Assert (Present (Corresponding_Record_Type (Pid))); + + if Ada_Version >= Ada_05 + and then Present (Protected_Definition (Parent (Pid))) + and then Present (Abstract_Interfaces + (Corresponding_Record_Type (Pid))) + then + declare + Vis_Decl : Node_Id := + First (Visible_Declarations + (Protected_Definition (Parent (Pid)))); + Wrap_Body : Node_Id; + + begin + -- Examine the visible declarations of the protected type, + -- looking for an entry declaration. We do not consider + -- entry families since they can not have dispatching + -- operations, thus they do not need entry wrappers. + + while Present (Vis_Decl) loop + if Nkind (Vis_Decl) = N_Entry_Declaration then + Wrap_Body := + Build_Wrapper_Body (Loc, + Proc_Nam => Defining_Identifier (Vis_Decl), + Obj_Typ => Corresponding_Record_Type (Pid), + Formals => Parameter_Specifications (Vis_Decl)); + + if Wrap_Body /= Empty then + Insert_After (Current_Node, Wrap_Body); + Current_Node := Wrap_Body; + + Analyze (Wrap_Body); + end if; + + elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then + Wrap_Body := + Build_Wrapper_Body (Loc, + Proc_Nam => Defining_Unit_Name + (Specification (Vis_Decl)), + Obj_Typ => Corresponding_Record_Type (Pid), + Formals => Parameter_Specifications + (Specification (Vis_Decl))); + + if Wrap_Body /= Empty then + Insert_After (Current_Node, Wrap_Body); + Current_Node := Wrap_Body; + + Analyze (Wrap_Body); + end if; + end if; + + Next (Vis_Decl); + end loop; + end; + end if; end Expand_N_Protected_Body; ----------------------------------------- @@ -5136,6 +5621,11 @@ package body Exp_Ch9 is (Component_List (Type_Definition (Rec_Decl))); end if; + -- Ada 2005 (AI-345): Propagate the attribute that contains the list + -- of implemented interfaces. + + Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); + Qualify_Entity_Names (N); -- If the type has discriminants, their occurrences in the declaration @@ -5353,6 +5843,70 @@ package body Exp_Ch9 is Analyze (Rec_Decl, Suppress => All_Checks); + -- Ada 2005 (AI-345): Construct the primitive entry wrappers before + -- the corresponding record is frozen + + if Ada_Version >= Ada_05 + and then Present (Visible_Declarations (Pdef)) + and then Present (Corresponding_Record_Type + (Defining_Identifier (Parent (Pdef)))) + and then Present (Abstract_Interfaces + (Corresponding_Record_Type + (Defining_Identifier (Parent (Pdef))))) + then + declare + Current_Node : Node_Id := Rec_Decl; + Vis_Decl : Node_Id; + Wrap_Spec : Node_Id; + New_N : Node_Id; + + begin + -- Examine the visible declarations of the protected type, looking + -- for declarations of entries, and subprograms. We do not + -- consider entry families since they can not have dispatching + -- operations, thus they do not need entry wrappers. + + Vis_Decl := First (Visible_Declarations (Pdef)); + + while Present (Vis_Decl) loop + + Wrap_Spec := Empty; + + if Nkind (Vis_Decl) = N_Entry_Declaration + and then not Present (Discrete_Subtype_Definition (Vis_Decl)) + then + Wrap_Spec := + Build_Wrapper_Spec (Loc, + Proc_Nam => Defining_Identifier (Vis_Decl), + Obj_Typ => Defining_Identifier (Rec_Decl), + Formals => Parameter_Specifications (Vis_Decl)); + + elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then + Wrap_Spec := + Build_Wrapper_Spec (Loc, + Proc_Nam => Defining_Unit_Name + (Specification (Vis_Decl)), + Obj_Typ => Defining_Identifier (Rec_Decl), + Formals => Parameter_Specifications + (Specification (Vis_Decl))); + + end if; + + if Wrap_Spec /= Empty then + New_N := Make_Subprogram_Declaration (Loc, + Specification => Wrap_Spec); + + Insert_After (Current_Node, New_N); + Current_Node := New_N; + + Analyze (New_N); + end if; + + Next (Vis_Decl); + end loop; + end; + end if; + -- Collect pointers to entry bodies and their barriers, to be placed -- in the Entry_Bodies_Array for the type. For each entry/family we -- add an expression to the aggregate which is the initial value of @@ -7038,6 +7592,62 @@ package body Exp_Ch9 is Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), Expression => New_Reference_To (Standard_True, Loc))); end if; + + -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies + -- after the task body. At this point the entry specs have been + -- created, frozen and included in the dispatch table for the task + -- type. + + pragma Assert (Present (Corresponding_Record_Type (Ttyp))); + + if Ada_Version >= Ada_05 + and then Present (Task_Definition (Parent (Ttyp))) + and then Present (Abstract_Interfaces + (Corresponding_Record_Type (Ttyp))) + then + declare + Current_Node : Node_Id; + Vis_Decl : Node_Id := + First (Visible_Declarations (Task_Definition (Parent (Ttyp)))); + Wrap_Body : Node_Id; + + begin + if Nkind (Parent (N)) = N_Subunit then + Current_Node := Corresponding_Stub (Parent (N)); + else + Current_Node := N; + end if; + + -- Examine the visible declarations of the task type, + -- looking for an entry declaration. We do not consider + -- entry families since they can not have dispatching + -- operations, thus they do not need entry wrappers. + + while Present (Vis_Decl) loop + if Nkind (Vis_Decl) = N_Entry_Declaration + and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry + then + + -- Create the specification of the wrapper + + Wrap_Body := + Build_Wrapper_Body (Loc, + Proc_Nam => Defining_Identifier (Vis_Decl), + Obj_Typ => Corresponding_Record_Type (Ttyp), + Formals => Parameter_Specifications (Vis_Decl)); + + if Wrap_Body /= Empty then + Insert_After (Current_Node, Wrap_Body); + Current_Node := Wrap_Body; + + Analyze (Wrap_Body); + end if; + end if; + + Next (Vis_Decl); + end loop; + end; + end if; end Expand_N_Task_Body; ------------------------------------ @@ -7160,6 +7770,12 @@ package body Exp_Ch9 is -- Here we will do the expansion Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); + + -- Ada 2005 (AI-345): Propagate the attribute that contains the list + -- of implemented interfaces. + + Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); + Rec_Ent := Defining_Identifier (Rec_Decl); Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); @@ -7412,20 +8028,76 @@ package body Exp_Ch9 is Set_Needs_Debug_Info (Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N))); - -- Now we can freeze the corresponding record. This needs manually - -- freezing, since it is really part of the task type, and the task - -- type is frozen at this stage. We of course need the initialization - -- procedure for this corresponding record type and we won't get it - -- in time if we don't freeze now. + -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs + -- before the corresponding record has been frozen. - declare - L : constant List_Id := Freeze_Entity (Rec_Ent, Loc); + if Ada_Version >= Ada_05 + and then Present (Taskdef) + and then Present (Corresponding_Record_Type + (Defining_Identifier (Parent (Taskdef)))) + and then Present (Abstract_Interfaces + (Corresponding_Record_Type + (Defining_Identifier (Parent (Taskdef))))) + then + declare + Current_Node : Node_Id := Rec_Decl; + Vis_Decl : Node_Id := First (Visible_Declarations (Taskdef)); + Wrap_Spec : Node_Id; + New_N : Node_Id; - begin - if Is_Non_Empty_List (L) then - Insert_List_After (Body_Decl, L); - end if; - end; + begin + -- Examine the visible declarations of the task type, + -- looking for an entry declaration. We do not consider + -- entry families since they can not have dispatching + -- operations, thus they do not need entry wrappers. + + while Present (Vis_Decl) loop + if Nkind (Vis_Decl) = N_Entry_Declaration + and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry + then + Wrap_Spec := + Build_Wrapper_Spec (Loc, + Proc_Nam => Defining_Identifier (Vis_Decl), + Obj_Typ => Etype (Rec_Ent), + Formals => Parameter_Specifications (Vis_Decl)); + + if Wrap_Spec /= Empty then + New_N := + Make_Subprogram_Declaration (Loc, + Specification => Wrap_Spec); + + Insert_After (Current_Node, New_N); + Current_Node := New_N; + + Analyze (New_N); + end if; + end if; + + Next (Vis_Decl); + end loop; + end; + end if; + + -- Ada 2005 (AI-345): We must defer freezing to allow further + -- declaration of primitive subprograms covering task interfaces + + if Ada_Version <= Ada_95 then + + -- Now we can freeze the corresponding record. This needs manually + -- freezing, since it is really part of the task type, and the task + -- type is frozen at this stage. We of course need the initialization + -- procedure for this corresponding record type and we won't get it + -- in time if we don't freeze now. + + declare + L : constant List_Id := Freeze_Entity (Rec_Ent, Loc); + + begin + if Is_Non_Empty_List (L) then + Insert_List_After (Body_Decl, L); + end if; + end; + end if; -- Complete the expansion of access types to the current task -- type, if any were declared. diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 65bcc3d3821..f4a58add325 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -32,7 +32,6 @@ with Exp_Util; use Exp_Util; with Namet; use Namet; with Nmake; use Nmake; with Nlists; use Nlists; -with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem_Res; use Sem_Res; with Sinfo; use Sinfo; @@ -192,12 +191,10 @@ package body Exp_Imgv is -- For types whose root type is Wide_Character -- xx = Wide_Character -- tv = Wide_Character (Expr) - -- pm = Wide_Character_Encoding_Method -- For types whose root type is Wide_Wide_Character -- xx = Wide_Wide_haracter -- tv = Wide_Wide_Character (Expr) - -- pm = Wide_Character_Encoding_Method -- For floating-point types -- xx = Floating_Point @@ -391,15 +388,6 @@ package body Exp_Imgv is Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Aft)); - -- For wide [wide] character, append encoding method - - elsif Rtyp = Standard_Wide_Character - or else Rtyp = Standard_Wide_Wide_Character - then - Append_To (Arglist, - Make_Integer_Literal (Loc, - Intval => Int (Wide_Character_Encoding_Method))); - -- For decimal, append Scale and also set to do literal conversion elsif Is_Decimal_Fixed_Point_Type (Rtyp) then @@ -434,6 +422,12 @@ package body Exp_Imgv is -- For types whose root type is Character -- xx = Character + -- For types whose root type is Wide_Character + -- xx = Wide_Character + + -- For types whose root type is Wide_Wide_Character + -- xx = Wide_Wide_Character + -- For types whose root type is Boolean -- xx = Boolean @@ -452,14 +446,6 @@ package body Exp_Imgv is -- For floating-point types and ordinary fixed-point types -- xx = Real - -- For types derived from Wide_Character, typ'Value (X) expands into - - -- Value_Wide_Character (X, Wide_Character_Encoding_Method) - - -- For types derived from Wide_Wide_Character, typ'Value (X) expands into - - -- Value_Wide_Wide_Character (X, Wide_Character_Encoding_Method) - -- For decimal types with size <= Integer'Size, typ'Value (X) -- expands into @@ -504,15 +490,9 @@ package body Exp_Imgv is elsif Rtyp = Standard_Wide_Character then Vid := RE_Value_Wide_Character; - Append_To (Args, - Make_Integer_Literal (Loc, - Intval => Int (Wide_Character_Encoding_Method))); elsif Rtyp = Standard_Wide_Wide_Character then Vid := RE_Value_Wide_Wide_Character; - Append_To (Args, - Make_Integer_Literal (Loc, - Intval => Int (Wide_Character_Encoding_Method))); elsif Rtyp = Base_Type (Standard_Short_Short_Integer) or else Rtyp = Base_Type (Standard_Short_Integer) @@ -686,42 +666,36 @@ package body Exp_Imgv is -- Result_Type (Width_Wide_Character ( -- Wide_Character (typ'First), -- Wide_Character (typ'Last), - -- Wide_Character_Encoding_Method); -- and typ'Wide_Width expands into: -- Result_Type (Wide_Width_Wide_Character ( -- Wide_Character (typ'First), -- Wide_Character (typ'Last)); - -- Wide_Character_Encoding_Method); -- and typ'Wide_Wide_Width expands into -- Result_Type (Wide_Wide_Width_Wide_Character ( -- Wide_Character (typ'First), -- Wide_Character (typ'Last)); - -- Wide_Character_Encoding_Method); -- For types derived from Wide_Wide_Character, typ'Width expands into -- Result_Type (Width_Wide_Wide_Character ( -- Wide_Wide_Character (typ'First), -- Wide_Wide_Character (typ'Last), - -- Wide_Character_Encoding_Method); -- and typ'Wide_Width expands into: -- Result_Type (Wide_Width_Wide_Wide_Character ( -- Wide_Wide_Character (typ'First), -- Wide_Wide_Character (typ'Last)); - -- Wide_Character_Encoding_Method); -- and typ'Wide_Wide_Width expands into -- Result_Type (Wide_Wide_Width_Wide_Wide_Char ( -- Wide_Wide_Character (typ'First), -- Wide_Wide_Character (typ'Last)); - -- Wide_Character_Encoding_Method); -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into @@ -914,14 +888,6 @@ package body Exp_Imgv is Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Last)))); - -- For enumeration'Wide_[Wide_]Width, add encoding method parameter - - if Attr /= Normal then - Append_To (Arglist, - Make_Integer_Literal (Loc, - Intval => Int (Wide_Character_Encoding_Method))); - end if; - Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, @@ -945,17 +911,6 @@ package body Exp_Imgv is Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Last))); - -- For Wide_[Wide_]Character'Width, add encoding method parameter - - if (Rtyp = Standard_Wide_Character - or else - Rtyp = Standard_Wide_Wide_Character) - and then Attr /= Normal then - Append_To (Arglist, - Make_Integer_Literal (Loc, - Intval => Int (Wide_Character_Encoding_Method))); - end if; - Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index c5875348494..905fe7e42a4 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -592,12 +592,12 @@ package body Exp_Strm is -- Call the function, and do an unchecked conversion of the result -- to the actual type of the prefix. If the target is a discriminant, - -- set target type to force a constraint check (13.13.2 (35)). + -- and we are in the body of the default implementation of a 'Read + -- attribute, set target type to force a constraint check (13.13.2(35)). - if Nkind (Targ) = N_Selected_Component - and then Present (Entity (Selector_Name (Targ))) - and then Ekind (Entity (Selector_Name (Targ))) - = E_Discriminant + if Nkind (Targ) = N_Identifier + and then Is_Internal_Name (Chars (Targ)) + and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read) then Res := Unchecked_Convert_To (Base_Type (P_Type), @@ -786,23 +786,41 @@ package body Exp_Strm is Decl : out Node_Id; Pnam : out Entity_Id) is - Stms : List_Id; + Out_Formal : Node_Id; + -- Expression denoting the out formal parameter + + Dcls : constant List_Id := New_List; + -- Declarations for the 'Read body + + Stms : List_Id := New_List; -- Statements for the 'Read body + Disc : Entity_Id; + -- Entity of the discriminant being processed + + Tmp_For_Disc : Entity_Id; + -- Temporary object used to read the value of Disc + + Tmps_For_Discs : constant List_Id := New_List; + -- List of object declarations for temporaries holding the read values + -- for the discriminants. + + Cstr : constant List_Id := New_List; + -- List of constraints to be applied on temporary record + + Discriminant_Checks : constant List_Id := New_List; + -- List of discriminant checks to be performed if the actual object + -- is constrained. + Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V); - -- Temporary, must hide formal (assignments to components of the + -- Temporary record must hide formal (assignments to components of the -- record are always generated with V as the identifier for the record). - Cstr : List_Id; - -- List of constraints to be applied on temporary - - Disc : Entity_Id; - Disc_Ref : Node_Id; - Block : Node_Id; + Constrained_Stms : List_Id := New_List; + -- Statements within the block where we have the constrained temporary begin - Stms := New_List; - Cstr := New_List; + Disc := First_Discriminant (Typ); -- A mutable type cannot be a tagged type, so we generate a new name @@ -812,33 +830,50 @@ package body Exp_Strm is Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); + Out_Formal := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pnam, Loc), + Selector_Name => Make_Identifier (Loc, Name_V)); + -- Generate Reads for the discriminants of the type. The discriminants -- need to be read before the rest of the components, so that - -- variants are initialized correctly. + -- variants are initialized correctly. The discriminants must be read + -- into temporary variables so an incomplete Read (interrupted by an + -- exception, for example) does not alter the passed object. while Present (Disc) loop - Disc_Ref := - Make_Selected_Component (Loc, - Prefix => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pnam, Loc), - Selector_Name => - Make_Identifier (Loc, Name_V)), - Selector_Name => New_Occurrence_Of (Disc, Loc)); + Tmp_For_Disc := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Disc), "D")); - Set_Assignment_OK (Disc_Ref); + Append_To (Tmps_For_Discs, + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp_For_Disc, + Object_Definition => New_Occurrence_Of (Etype (Disc), Loc))); + Set_No_Initialization (Last (Tmps_For_Discs)); Append_To (Stms, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Etype (Disc), Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Disc_Ref))); + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + New_Occurrence_Of (Tmp_For_Disc, Loc)))); Append_To (Cstr, Make_Discriminant_Association (Loc, Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)), - Expression => New_Copy_Tree (Disc_Ref))); + Expression => New_Occurrence_Of (Tmp_For_Disc, Loc))); + + Append_To (Discriminant_Checks, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc), + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Out_Formal), + Selector_Name => New_Occurrence_Of (Disc, Loc))), + Reason => CE_Discriminant_Check_Failed)); Next_Discriminant (Disc); end loop; @@ -854,27 +889,33 @@ package body Exp_Strm is -- prior to being initialized. To this effect, we wrap the component -- assignments in a block where V is a constrained temporary. - Block := + Append_To (Dcls, + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Cstr)))); + + Constrained_Stms := Statements (Handled_Statement_Sequence (Decl)); + Append_To (Stms, Make_Block_Statement (Loc, - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Tmp, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Typ, Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => Cstr)))), - Handled_Statement_Sequence => - Handled_Statement_Sequence (Decl)); - - Append_To (Stms, Block); - - Append_To (Statements (Handled_Statement_Sequence (Block)), + Declarations => Dcls, + Handled_Statement_Sequence => Parent (Constrained_Stms))); + + Append_To (Constrained_Stms, + Make_Implicit_If_Statement (Pnam, + Condition => + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Out_Formal), + Attribute_Name => Name_Constrained), + Then_Statements => Discriminant_Checks)); + + Append_To (Constrained_Stms, Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pnam, Loc), - Selector_Name => Make_Identifier (Loc, Name_V)), + Name => Out_Formal, Expression => Make_Identifier (Loc, Name_V))); if Is_Unchecked_Union (Typ) then @@ -890,6 +931,7 @@ package body Exp_Strm is Reason => PE_Unchecked_Union_Restriction)); end if; + Set_Declarations (Decl, Tmps_For_Discs); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 50d96053817..78bc1825a75 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -235,11 +235,7 @@ package body Exp_Tss is function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is begin - Get_Name_String (Chars (Typ)); - Name_Len := Name_Len + 2; - Name_Buffer (Name_Len - 1) := TSS_Init_Proc (1); - Name_Buffer (Name_Len) := TSS_Init_Proc (2); - return Name_Find; + return Make_TSS_Name (Typ, TSS_Init_Proc); end Make_Init_Proc_Name; ------------------------- @@ -252,10 +248,10 @@ package body Exp_Tss is is begin Get_Name_String (Chars (Typ)); - Add_Char_To_Name_Buffer (Nam (1)); - Add_Char_To_Name_Buffer (Nam (2)); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (Increment_Serial_Number); + Add_Char_To_Name_Buffer (Nam (1)); + Add_Char_To_Name_Buffer (Nam (2)); return Name_Find; end Make_TSS_Name_Local; diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index de3a20f6e68..8be57a419f9 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -64,9 +64,13 @@ package Exp_Tss is -- TSS Naming -- ---------------- - -- A TSS is identified by its Chars name. The name has the form typXY, - -- where typ is the type name, and XY are two characters that identify - -- the particular TSS routine, using the following codes: + -- A TSS is identified by its Chars name. The name has the form typXY or + -- typ_<serial>XY, where typ is the type name, and XY are two characters + -- that identify the particular TSS routine. A unique serial number is + -- included for the case where several local instances of the same TSS + -- must be generated (see discussion under Make_TSS_Name_Local). + + -- The following codes are used to denote TSSs: -- Note: When making additions to this list, update the list in snames.adb @@ -126,10 +130,11 @@ package Exp_Tss is function Make_TSS_Name_Local (Typ : Entity_Id; Nam : TSS_Name_Type) return Name_Id; - -- Similar to the above call, but a string of the form _nnn is appended - -- to the name, where nnn is a unique serial number. This is used when - -- multiple instances of the same TSS routine may be generated in the - -- same scope (see also discussion above of current limitations). + -- Similar to the above call, but a string of the form _nnn is inserted + -- before the TSS code suffix, where nnn is a unique serial number. This + -- is used when multiple instances of the same TSS routine may be + -- generated in the same scope (see also discussion above of current + -- limitations). function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id; -- Version for init procs, same as Make_TSS_Name (Typ, TSS_Init_Proc) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8ba5fe8a1f8..cb4c5328135 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1380,17 +1380,17 @@ package body Freeze is Atype : Entity_Id; procedure Check_Current_Instance (Comp_Decl : Node_Id); - -- Check that an Access or Unchecked_Access attribute with - -- a prefix which is the current instance type can only be - -- applied when the type is limited. + -- Check that an Access or Unchecked_Access attribute with a prefix + -- which is the current instance type can only be applied when the type + -- is limited. function After_Last_Declaration return Boolean; -- If Loc is a freeze_entity that appears after the last declaration -- in the scope, inhibit error messages on late completion. procedure Freeze_Record_Type (Rec : Entity_Id); - -- Freeze each component, handle some representation clauses, and - -- freeze primitive operations if this is a tagged type. + -- Freeze each component, handle some representation clauses, and freeze + -- primitive operations if this is a tagged type. ---------------------------- -- After_Last_Declaration -- @@ -3010,26 +3010,40 @@ package body Freeze is elsif Is_Integer_Type (E) then Adjust_Esize_For_Alignment (E); - elsif Is_Access_Type (E) - and then No (Associated_Storage_Pool (E)) - then - Check_Restriction (No_Standard_Storage_Pools, E); + elsif Is_Access_Type (E) then + + -- Check restriction for standard storage pool + + if No (Associated_Storage_Pool (E)) then + Check_Restriction (No_Standard_Storage_Pools, E); + end if; + + -- Deal with error message for pure access type. This is not an + -- error in Ada 2005 if there is no pool (see AI-366). + + if Is_Pure_Unit_Access_Type (E) + and then (Ada_Version < Ada_05 + or else not No_Pool_Assigned (E)) + then + Error_Msg_N ("named access type not allowed in pure unit", E); + end if; end if; + -- Case of composite types + if Is_Composite_Type (E) then - -- AI-117 requires that all new primitives of a tagged type - -- must inherit the convention of the full view of the type. - -- Inherited and overriding operations are defined to inherit - -- the convention of their parent or overridden subprogram - -- (also specified in AI-117), and that will have occurred - -- earlier (in Derive_Subprogram and New_Overloaded_Entity). - -- Here we set the convention of primitives that are still - -- convention Ada, which will ensure that any new primitives - -- inherit the type's convention. Class-wide types can have - -- a foreign convention inherited from their specific type, - -- but are excluded from this since they don't have any - -- associated primitives. + -- AI-117 requires that all new primitives of a tagged type must + -- inherit the convention of the full view of the type. Inherited + -- and overriding operations are defined to inherit the convention + -- of their parent or overridden subprogram (also specified in + -- AI-117), and that will have occurred earlier (in + -- Derive_Subprogram and New_Overloaded_Entity). Here we set the + -- convention of primitives that are still convention Ada, which + -- will ensure that any new primitives inherit the type's + -- convention. Class-wide types can have a foreign convention + -- inherited from their specific type, but are excluded from this + -- since they don't have any associated primitives. if Is_Tagged_Type (E) and then not Is_Class_Wide_Type (E) @@ -3057,19 +3071,41 @@ package body Freeze is and then not Is_Class_Wide_Type (E) then declare - Prim_List : constant Elist_Id := Primitive_Operations (E); + Prim_List : Elist_Id; Prim : Elmt_Id; Ent : Entity_Id; begin + -- Ada 2005 (AI-345): In case of concurrent type generate + -- reference to the wrapper that allow us to dispatch calls + -- through their implemented abstract interface types. + + -- The check for Present here is to protect against previously + -- reported critical errors. + + if Is_Concurrent_Type (E) + and then Present (Corresponding_Record_Type (E)) + then + pragma Assert (not Is_Empty_Elmt_List + (Abstract_Interfaces + (Corresponding_Record_Type (E)))); + + Prim_List := Primitive_Operations + (Corresponding_Record_Type (E)); + else + Prim_List := Primitive_Operations (E); + end if; + + -- Loop to generate references for primitive operations + Prim := First_Elmt (Prim_List); while Present (Prim) loop Ent := Node (Prim); - -- If the operation is derived, get the original for - -- cross-reference purposes (it is the original for - -- which we want the xref, and for which the comes - -- from source test needs to be performed). + -- If the operation is derived, get the original for cross- + -- reference purposes (it is the original for which we want + -- the xref, and for which the comes from source test needs + -- to be performed). while Present (Alias (Ent)) loop Ent := Alias (Ent); @@ -3337,10 +3373,10 @@ package body Freeze is -- Start of processing for Freeze_Expression begin - -- Immediate return if freezing is inhibited. This flag is set by - -- the analyzer to stop freezing on generated expressions that would - -- cause freezing if they were in the source program, but which are - -- not supposed to freeze, since they are created. + -- Immediate return if freezing is inhibited. This flag is set by the + -- analyzer to stop freezing on generated expressions that would cause + -- freezing if they were in the source program, but which are not + -- supposed to freeze, since they are created. if Must_Not_Freeze (N) then return; @@ -3468,12 +3504,12 @@ package body Freeze is case Nkind (Parent_P) is - -- A special test for the exception of (RM 13.14(8)) for the - -- case of per-object expressions (RM 3.8(18)) occurring in a - -- component definition or a discrete subtype definition. Note - -- that we test for a component declaration which includes both - -- cases we are interested in, and furthermore the tree does not - -- have explicit nodes for either of these two constructs. + -- A special test for the exception of (RM 13.14(8)) for the case + -- of per-object expressions (RM 3.8(18)) occurring in component + -- definition or a discrete subtype definition. Note that we test + -- for a component declaration which includes both cases we are + -- interested in, and furthermore the tree does not have explicit + -- nodes for either of these two constructs. when N_Component_Declaration => @@ -3504,9 +3540,9 @@ package body Freeze is end if; end if; - -- If we have an enumeration literal that appears as the - -- choice in the aggregate of an enumeration representation - -- clause, then freezing does not occur (RM 13.14(10)). + -- If we have an enumeration literal that appears as the choice in + -- the aggregate of an enumeration representation clause, then + -- freezing does not occur (RM 13.14(10)). when N_Enumeration_Representation_Clause => @@ -3545,11 +3581,11 @@ package body Freeze is when N_Handled_Sequence_Of_Statements => - -- An exception occurs when the sequence of statements is - -- for an expander generated body that did not do the usual - -- freeze all operation. In this case we usually want to - -- freeze outside this body, not inside it, and we skip - -- past the subprogram body that we are inside. + -- An exception occurs when the sequence of statements is for + -- an expander generated body that did not do the usual freeze + -- all operation. In this case we usually want to freeze + -- outside this body, not inside it, and we skip past the + -- subprogram body that we are inside. if In_Exp_Body (Parent_P) then @@ -3631,11 +3667,11 @@ package body Freeze is -- Note: The N_Loop_Statement is a special case. A type that -- appears in the source can never be frozen in a loop (this - -- occurs only because of a loop expanded by the expander), - -- so we keep on going. Otherwise we terminate the search. - -- Same is true of any entity which comes from source. (if they - -- have a predefined type, that type does not appear to come - -- from source, but the entity should not be frozen here). + -- occurs only because of a loop expanded by the expander), so we + -- keep on going. Otherwise we terminate the search. Same is true + -- of any entity which comes from source. (if they have a + -- predefined type, that type does not appear to come from source, + -- but the entity should not be frozen here). when N_Loop_Statement => exit when not Comes_From_Source (Etype (N)) @@ -3653,17 +3689,17 @@ package body Freeze is P := Parent_P; end loop; - -- If the expression appears in a record or an initialization - -- procedure, the freeze nodes are collected and attached to - -- the current scope, to be inserted and analyzed on exit from - -- the scope, to insure that generated entities appear in the - -- correct scope. If the expression is a default for a discriminant - -- specification, the scope is still void. The expression can also - -- appear in the discriminant part of a private or concurrent type. + -- If the expression appears in a record or an initialization procedure, + -- the freeze nodes are collected and attached to the current scope, to + -- be inserted and analyzed on exit from the scope, to insure that + -- generated entities appear in the correct scope. If the expression is + -- a default for a discriminant specification, the scope is still void. + -- The expression can also appear in the discriminant part of a private + -- or concurrent type. -- If the expression appears in a constrained subcomponent of an - -- enclosing record declaration, the freeze nodes must be attached - -- to the outer record type so they can eventually be placed in the + -- enclosing record declaration, the freeze nodes must be attached to + -- the outer record type so they can eventually be placed in the -- enclosing declaration list. -- The other case requiring this special handling is if we are in @@ -3760,15 +3796,15 @@ package body Freeze is -- Freeze_Fixed_Point_Type -- ----------------------------- - -- Certain fixed-point types and subtypes, including implicit base - -- types and declared first subtypes, have not yet set up a range. - -- This is because the range cannot be set until the Small and Size - -- values are known, and these are not known till the type is frozen. + -- Certain fixed-point types and subtypes, including implicit base types + -- and declared first subtypes, have not yet set up a range. This is + -- because the range cannot be set until the Small and Size values are + -- known, and these are not known till the type is frozen. - -- To signal this case, Scalar_Range contains an unanalyzed syntactic - -- range whose bounds are unanalyzed real literals. This routine will - -- recognize this case, and transform this range node into a properly - -- typed range with properly analyzed and resolved values. + -- To signal this case, Scalar_Range contains an unanalyzed syntactic range + -- whose bounds are unanalyzed real literals. This routine will recognize + -- this case, and transform this range node into a properly typed range + -- with properly analyzed and resolved values. procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is Rng : constant Node_Id := Scalar_Range (Typ); @@ -3892,10 +3928,10 @@ package body Freeze is end if; -- Compute the fudged bounds. If the number is a model number, - -- then we do nothing to include it, but we are allowed to - -- backoff to the next adjacent model number when we exclude - -- it. If it is not a model number then we straddle the two - -- values with the model numbers on either side. + -- then we do nothing to include it, but we are allowed to backoff + -- to the next adjacent model number when we exclude it. If it is + -- not a model number then we straddle the two values with the + -- model numbers on either side. Model_Num := UR_Trunc (Loval / Small) * Small; @@ -4028,28 +4064,26 @@ package body Freeze is Actual_Hi := Hival_Incl_EP; end if; - -- One pathological case: normally we never fudge a low - -- bound down, since it would seem to increase the size - -- (if it has any effect), but for ranges containing a - -- single value, or no values, the high bound can be - -- small too large. Consider: + -- One pathological case: normally we never fudge a low bound + -- down, since it would seem to increase the size (if it has + -- any effect), but for ranges containing single value, or no + -- values, the high bound can be small too large. Consider: -- type t is delta 2.0**(-14) -- range 131072.0 .. 0; - -- That lower bound is *just* outside the range of 32 - -- bits, and does need fudging down in this case. Note - -- that the bounds will always have crossed here, since - -- the high bound will be fudged down if necessary, as - -- in the case of: + -- That lower bound is *just* outside the range of 32 bits, and + -- does need fudging down in this case. Note that the bounds + -- will always have crossed here, since the high bound will be + -- fudged down if necessary, as in the case of: -- type t is delta 2.0**(-14) -- range 131072.0 .. 131072.0; - -- So we can detect the situation by looking for crossed - -- bounds, and if the bounds are crossed, and the low - -- bound is greater than zero, we will always back it - -- off by small, since this is completely harmless. + -- So we detect the situation by looking for crossed bounds, + -- and if the bounds are crossed, and the low bound is greater + -- than zero, we will always back it off by small, since this + -- is completely harmless. if Actual_Lo > Actual_Hi then if UR_Is_Positive (Actual_Lo) then @@ -4119,9 +4153,9 @@ package body Freeze is Adjust_Esize_For_Alignment (Typ); end if; - -- If we have a base type, then expand the bounds so that they - -- extend to the full width of the allocated size in bits, to - -- avoid junk range checks on intermediate computations. + -- If we have a base type, then expand the bounds so that they extend to + -- the full width of the allocated size in bits, to avoid junk range + -- checks on intermediate computations. if Base_Type (Typ) = Typ then Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1)))); @@ -4135,9 +4169,9 @@ package body Freeze is Set_Analyzed (Lo, False); Analyze (Lo); - -- Resolve with universal fixed if the base type, and the base - -- type if it is a subtype. Note we can't resolve the base type - -- with itself, that would be a reference before definition. + -- Resolve with universal fixed if the base type, and the base type if + -- it is a subtype. Note we can't resolve the base type with itself, + -- that would be a reference before definition. if Typ = Btyp then Resolve (Lo, Universal_Fixed); @@ -4360,10 +4394,10 @@ package body Freeze is begin Ensure_Type_Is_SA (Etype (E)); - -- Reset True_Constant flag, since something strange is going on - -- with the scoping here, and our simple value tracing may not - -- be sufficient for this indication to be reliable. We kill the - -- Constant_Value indication for the same reason. + -- Reset True_Constant flag, since something strange is going on with + -- the scoping here, and our simple value tracing may not be sufficient + -- for this indication to be reliable. We kill the Constant_Value + -- indication for the same reason. Set_Is_True_Constant (E, False); Set_Current_Value (E, Empty); @@ -4411,9 +4445,9 @@ package body Freeze is -- Reset the Pure indication on an imported subprogram unless an -- explicit Pure_Function pragma was present. We do this because -- otherwise it is an insidious error to call a non-pure function - -- from a pure unit and have calls mysteriously optimized away. - -- What happens here is that the Import can bypass the normal - -- check to ensure that pure units call only pure subprograms. + -- from pure unit and have calls mysteriously optimized away. What + -- happens here is that the Import can bypass the normal check to + -- ensure that pure units call only pure subprograms. if Is_Imported (E) and then Is_Pure (E) @@ -4464,8 +4498,8 @@ package body Freeze is null; -- If the return type is generic, we have emitted a warning - -- earlier on, and there is nothing else to check here. - -- Specific instantiations may lead to erroneous behavior. + -- earlier on, and there is nothing else to check here. Specific + -- instantiations may lead to erroneous behavior. elsif Is_Generic_Type (Etype (E)) then null; @@ -4483,8 +4517,8 @@ package body Freeze is end if; -- If any of the formals for an exported foreign convention - -- subprogram have defaults, then emit an appropriate warning - -- since this is odd (default cannot be used from non-Ada code) + -- subprogram have defaults, then emit an appropriate warning since + -- this is odd (default cannot be used from non-Ada code) if Is_Exported (E) then F := First_Formal (E); @@ -4520,6 +4554,17 @@ package body Freeze is end loop; end if; end if; + + -- Pragma Inline_Always is disallowed for dispatching subprograms + -- because the address of such subprograms is saved in the dispatch + -- table to support dispatching calls, and dispatching calls cannot + -- be inlined. This is consistent with the restriction against using + -- 'Access or 'Address on an Inline_Always subprogram. + + if Is_Dispatching_Operation (E) and then Is_Always_Inlined (E) then + Error_Msg_N + ("pragma Inline_Always not allowed for dispatching subprograms", E); + end if; end Freeze_Subprogram; ---------------------- @@ -4861,9 +4906,9 @@ package body Freeze is return; end if; - -- We only give the warning for non-imported entities of a type - -- for which a non-null base init proc is defined (or for access - -- types which have implicit null initialization). + -- We only give the warning for non-imported entities of a type for + -- which a non-null base init proc is defined (or for access types which + -- have implicit null initialization). if Present (Expr) and then (Has_Non_Null_Base_Init_Proc (Typ) diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index bf76e4704b4..35ea324d609 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -354,8 +354,10 @@ package body Ch10 is elsif Token = Tok_Separate then Set_Unit (Comp_Unit_Node, P_Subunit); - elsif Token = Tok_Procedure - or else Token = Tok_Function + elsif Token = Tok_Function + or else Token = Tok_Not + or else Token = Tok_Overriding + or else Token = Tok_Procedure then Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam)); diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index ae6b6cd48d5..0f35d836258 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -898,11 +898,13 @@ package body Ch12 is -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> - -- DEFAULT_NAME ::= NAME + -- DEFAULT_NAME ::= NAME | null -- The caller has checked that the initial tokens are WITH FUNCTION or -- WITH PROCEDURE, and the initial WITH has been scanned out. + -- A null default is an Ada 2005 feature. + -- Error recovery: cannot raise Error_Resync function P_Formal_Subprogram_Declaration return Node_Id is @@ -940,6 +942,22 @@ package body Ch12 is Scan; -- past <> T_Semicolon; + elsif Token = Tok_Null then + if Ada_Version < Ada_05 then + Error_Msg_SP + ("null default subprograms are an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + if Nkind (Spec_Node) = N_Procedure_Specification then + Set_Null_Present (Spec_Node); + else + Error_Msg_SP ("only procedures can be null"); + end if; + + Scan; -- past NULL + T_Semicolon; + else Set_Default_Name (Def_Node, P_Name); T_Semicolon; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 48af5bada8f..8aa4fe87728 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,7 @@ package body Ch6 is function P_Defining_Operator_Symbol return Node_Id; procedure Check_Junk_Semicolon_Before_Return; + -- Check for common error of junk semicolon before RETURN keyword of -- function specification. If present, skip over it with appropriate -- error message, leaving Scan_Ptr pointing to the RETURN after. This @@ -58,7 +59,7 @@ package body Ch6 is if Token = Tok_Return then Restore_Scan_State (Scan_State); - Error_Msg_SC ("Unexpected semicolon ignored"); + Error_Msg_SC ("unexpected semicolon ignored"); Scan; -- rescan past junk semicolon else @@ -109,6 +110,13 @@ package body Ch6 is -- | function DEFINING_DESIGNATOR is -- new generic_function_NAME [GENERIC_ACTUAL_PART]; + -- NULL_PROCEDURE_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION is null; + + -- Null procedures are an Ada 2005 feature. A null procedure declaration + -- is classified as a basic declarative item, but it is parsed here, with + -- other subprogram constructs. + -- The value in Pf_Flags indicates which of these possible declarations -- is acceptable to the caller: @@ -123,7 +131,8 @@ package body Ch6 is -- context is issued. The only possible values for Pf_Flags are those -- defined as constants in the Par package. - -- The caller has checked that the initial token is FUNCTION or PROCEDURE + -- The caller has checked that the initial token is FUNCTION, PROCEDURE, + -- NOT or OVERRIDING. -- Error recovery: cannot raise Error_Resync @@ -143,6 +152,13 @@ package body Ch6 is Func : Boolean; Scan_State : Saved_Scan_State; + -- Flags for optional overriding indication. Two flags are needed, + -- to distinguish positive and negative overriding indicators from + -- the absence of any indicator. + + Is_Overriding : Boolean := False; + Not_Overriding : Boolean := False; + begin -- Set up scope stack entry. Note that the Labl field will be set later @@ -154,6 +170,41 @@ package body Ch6 is Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Lreq := False; + -- Ada2005: scan leading overriding indicator. + + if Token = Tok_Not then + Scan; -- past NOT + + if Token = Tok_Overriding then + Scan; -- past OVERRIDING + Not_Overriding := True; + else + Error_Msg_SC ("OVERRIDING expected!"); + end if; + + elsif Token = Tok_Overriding then + Scan; -- past OVERRIDING + Is_Overriding := True; + end if; + + if (Is_Overriding or else Not_Overriding) then + if Ada_Version < Ada_05 then + Error_Msg_SP (" overriding indicator is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + + -- An overriding indicator is allowed for subprogram declarations, + -- bodies, renamings, stubs, and instantiations. + + elsif Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub then + Error_Msg_SC ("overriding indicator not allowed here!"); + + elsif Token /= Tok_Function + and then Token /= Tok_Procedure + then + Error_Msg_SC ("FUNCTION or PROCEDURE expected!"); + end if; + end if; + Func := (Token = Tok_Function); Fproc_Sloc := Token_Ptr; Scan; -- past FUNCTION or PROCEDURE @@ -202,7 +253,7 @@ package body Ch6 is if Token = Tok_Is then Save_Scan_State (Scan_State); -- at the IS - T_Is; -- checks for redundant IS's + T_Is; -- checks for redundant IS if Token = Tok_New then if not Pf_Flags.Gins then @@ -223,6 +274,14 @@ package body Ch6 is Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); TF_Semicolon; Pop_Scope_Stack; -- Don't need scope stack entry in this case + + if Is_Overriding then + Set_Must_Override (Inst_Node); + + elsif Not_Overriding then + Set_Must_Not_Override (Inst_Node); + end if; + return Inst_Node; else @@ -291,6 +350,13 @@ package body Ch6 is Set_Defining_Unit_Name (Specification_Node, Name_Node); Set_Parameter_Specifications (Specification_Node, Fpart_List); + if Is_Overriding then + Set_Must_Override (Specification_Node); + + elsif Not_Overriding then + Set_Must_Not_Override (Specification_Node); + end if; + -- Error check: barriers not allowed on protected functions/procedures if Token = Tok_When then @@ -384,6 +450,25 @@ package body Ch6 is TF_Semicolon; return Absdec_Node; + -- Ada 2005 (AI-248): Parse a null procedure declaration + + elsif Token = Tok_Null then + if Ada_Version < Ada_05 then + Error_Msg_SP ("null procedures are an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Scan; -- past NULL + + if Func then + Error_Msg_SP ("only procedures can be null"); + else + Set_Null_Present (Specification_Node); + end if; + + TF_Semicolon; + goto Subprogram_Declaration; + -- Check for IS NEW with Formal_Part present and handle nicely elsif Token = Tok_New then diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index eba22acbb28..8e58931c366 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -185,6 +185,11 @@ package body Ch9 is end if; Scan; -- past WITH + + if Token = Tok_Private then + Error_Msg_SP + ("PRIVATE not allowed in task type declaration"); + end if; end if; Set_Task_Definition (Task_Node, P_Task_Definition); @@ -240,7 +245,7 @@ package body Ch9 is -- Deal gracefully with multiple PRIVATE parts while Token = Tok_Private loop - Error_Msg_SC ("Only one private part allowed per task"); + Error_Msg_SC ("only one private part allowed per task"); Scan; -- past PRIVATE Append_List (P_Task_Items, Private_Declarations (Def_Node)); end loop; @@ -284,7 +289,13 @@ package body Ch9 is if Token = Tok_Pragma then Append (P_Pragma, Items); - elsif Token = Tok_Entry then + -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING + -- may begin an entry declaration. + + elsif Token = Tok_Entry + or else Token = Tok_Not + or else Token = Tok_Overriding + then Append (P_Entry_Declaration, Items); elsif Token = Tok_For then @@ -311,7 +322,7 @@ package body Ch9 is elsif Token = Tok_Identifier or else Token in Token_Class_Declk then - Error_Msg_SC ("Illegal declaration in task definition"); + Error_Msg_SC ("illegal declaration in task definition"); Resync_Past_Semicolon; else @@ -454,6 +465,11 @@ package body Ch9 is end if; Scan; -- past WITH + + if Token = Tok_Private then + Error_Msg_SP + ("PRIVATE not allowed in protected type declaration"); + end if; end if; Set_Protected_Definition (Protected_Node, P_Protected_Definition); @@ -561,6 +577,63 @@ package body Ch9 is L : List_Id; P : Source_Ptr; + function P_Entry_Or_Subprogram_With_Indicator return Node_Id; + -- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding + -- indicator. The caller has checked that the initial token is NOT or + -- OVERRIDING. + + ------------------------------------------ + -- P_Entry_Or_Subprogram_With_Indicator -- + ------------------------------------------ + + function P_Entry_Or_Subprogram_With_Indicator return Node_Id is + Decl : Node_Id := Error; + Is_Overriding : Boolean := False; + Not_Overriding : Boolean := False; + + begin + if Token = Tok_Not then + Scan; -- past NOT + + if Token = Tok_Overriding then + Scan; -- past OVERRIDING + Not_Overriding := True; + else + Error_Msg_SC ("OVERRIDING expected!"); + end if; + + else + Scan; -- past OVERRIDING + Is_Overriding := True; + end if; + + if (Is_Overriding or else Not_Overriding) then + if Ada_Version < Ada_05 then + Error_Msg_SP (" overriding indicator is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + + elsif Token = Tok_Entry then + Decl := P_Entry_Declaration; + + Set_Must_Override (Decl, Is_Overriding); + Set_Must_Not_Override (Decl, Not_Overriding); + + elsif Token = Tok_Function or else Token = Tok_Procedure then + Decl := P_Subprogram (Pf_Decl); + + Set_Must_Override (Specification (Decl), Is_Overriding); + Set_Must_Not_Override (Specification (Decl), Not_Overriding); + + else + Error_Msg_SC ("ENTRY, FUNCTION or PROCEDURE expected!"); + end if; + end if; + + return Decl; + end P_Entry_Or_Subprogram_With_Indicator; + + -- Start of processing for P_Protected_Operation_Declaration_Opt + begin -- This loop runs more than once only when a junk declaration -- is skipped. @@ -569,6 +642,9 @@ package body Ch9 is if Token = Tok_Pragma then return P_Pragma; + elsif Token = Tok_Not or else Token = Tok_Overriding then + return P_Entry_Or_Subprogram_With_Indicator; + elsif Token = Tok_Entry then return P_Entry_Declaration; @@ -669,10 +745,12 @@ package body Ch9 is ------------------------------ -- ENTRY_DECLARATION ::= + -- [OVERRIDING_INDICATOR] -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)] -- PARAMETER_PROFILE; - -- The caller has checked that the initial token is ENTRY + -- The caller has checked that the initial token is ENTRY, NOT or + -- OVERRIDING. -- Error recovery: cannot raise Error_Resync @@ -680,7 +758,41 @@ package body Ch9 is Decl_Node : Node_Id; Scan_State : Saved_Scan_State; + -- Flags for optional overriding indication. Two flags are needed, + -- to distinguish positive and negative overriding indicators from + -- the absence of any indicator. + + Is_Overriding : Boolean := False; + Not_Overriding : Boolean := False; + begin + -- Ada 2005 (AI-397): Scan leading overriding indicator. + + if Token = Tok_Not then + Scan; -- past NOT + + if Token = Tok_Overriding then + Scan; -- part OVERRIDING + Not_Overriding := True; + else + Error_Msg_SC ("OVERRIDING expected!"); + end if; + + elsif Token = Tok_Overriding then + Scan; -- part OVERRIDING + Is_Overriding := True; + end if; + + if (Is_Overriding or else Not_Overriding) then + if Ada_Version < Ada_05 then + Error_Msg_SP (" overriding indicator is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + + elsif Token /= Tok_Entry then + Error_Msg_SC ("ENTRY expected!"); + end if; + end if; + Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr); Scan; -- past ENTRY @@ -724,6 +836,12 @@ package body Ch9 is end if; end if; + if Is_Overriding then + Set_Must_Override (Decl_Node); + elsif Not_Overriding then + Set_Must_Not_Override (Decl_Node); + end if; + -- Error recovery check for illegal return if Token = Tok_Return then diff --git a/gcc/ada/s-imgwch.adb b/gcc/ada/s-imgwch.adb index 3ca5cccbe2c..c8c59f3fe9b 100644 --- a/gcc/ada/s-imgwch.adb +++ b/gcc/ada/s-imgwch.adb @@ -34,8 +34,6 @@ with Interfaces; use Interfaces; with System.Img_Char; use System.Img_Char; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; package body System.Img_WChar is @@ -44,42 +42,12 @@ package body System.Img_WChar is -------------------------- function Image_Wide_Character - (V : Wide_Character; - EM : WC_Encoding_Method) return String + (V : Wide_Character) return String is - Val : constant Unsigned_16 := Wide_Character'Pos (V); - WS : Wide_String (1 .. 3); - begin - -- If in range of standard character, use standard character routine - - if Val < 16#80# - or else (Val <= 16#FF# - and then EM not in WC_Upper_Half_Encoding_Method) - then - return Image_Character (Character'Val (Val)); - - -- if the value is one of the last two characters in the type, use - -- their language-defined names (3.5.2(3)). - - elsif Val = 16#FFFE# then - return "FFFE"; - - elsif Val = 16#FFFF# then - return "FFFF"; - - -- Otherwise return an appropriate escape sequence (i.e. one matching - -- the convention implemented by Scn.Wide_Char). The easiest thing is - -- to build a wide string for the result, and then use the Wide_Value - -- function to build the resulting String. - - else - WS (1) := '''; - WS (2) := V; - WS (3) := '''; - - return Wide_String_To_String (WS, EM); - end if; + return + Image_Wide_Wide_Character + (Wide_Wide_Character'Val (Wide_Character'Pos (V))); end Image_Wide_Character; ------------------------------- @@ -87,30 +55,32 @@ package body System.Img_WChar is ------------------------------- function Image_Wide_Wide_Character - (V : Wide_Wide_Character; - EM : WC_Encoding_Method) return String + (V : Wide_Wide_Character) return String is - Val : constant Unsigned_32 := Wide_Wide_Character'Pos (V); - WS : Wide_Wide_String (1 .. 3); + Val : Unsigned_32 := Wide_Wide_Character'Pos (V); begin - -- If in range of standard Wide_Character, then we use the - -- Wide_Character routine + -- If in range of standard Character, use Character routine - if Val <= 16#FFFF# then - return Image_Wide_Character (Wide_Character'Val (Val), EM); + if Val <= 16#FF# then + return Image_Character (Character'Val (Wide_Wide_Character'Pos (V))); - -- Otherwise return an appropriate escape sequence (i.e. one matching - -- the convention implemented by Scn.Wide_Wide_Char). The easiest thing - -- is to build a wide string for the result, and then use the - -- Wide_Wide_Value function to build the resulting String. + -- Otherwise value returned is Hex_hhhhhhhh else - WS (1) := '''; - WS (2) := V; - WS (3) := '''; - - return Wide_Wide_String_To_String (WS, EM); + declare + Result : String (1 .. 12) := "Hex_hhhhhhhh"; + Hex : constant array (Unsigned_32 range 0 .. 15) of Character := + "0123456789ABCDEF"; + + begin + for J in reverse 5 .. 12 loop + Result (J) := Hex (Val mod 16); + Val := Val / 16; + end loop; + + return Result; + end; end if; end Image_Wide_Wide_Character; diff --git a/gcc/ada/s-imgwch.ads b/gcc/ada/s-imgwch.ads index fa472aa26d4..ba180484978 100644 --- a/gcc/ada/s-imgwch.ads +++ b/gcc/ada/s-imgwch.ads @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUNTIME COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ W C H A R -- -- -- @@ -33,27 +33,13 @@ -- Wide_[Wide_]Character'Image -with System.WCh_Con; - package System.Img_WChar is pragma Pure (Img_WChar); - function Image_Wide_Character - (V : Wide_Character; - EM : System.WCh_Con.WC_Encoding_Method) return String; - -- Computes Wide_Character'Image (V) and returns the computed result, - -- The argument EM is a constant representing the encoding method in use. - -- The encoding method used is guaranteed to be consistent across a - -- given program execution and to correspond to the method used in the - -- source programs. + function Image_Wide_Character (V : Wide_Character) return String; + -- Computes Wide_Character'Image (V) and returns the computed result - function Image_Wide_Wide_Character - (V : Wide_Wide_Character; - EM : System.WCh_Con.WC_Encoding_Method) return String; - -- Computes Wide_Wide_Character'Image (V) and returns the computed result, - -- The argument EM is a constant representing the encoding method in use. - -- The encoding method used is guaranteed to be consistent across a - -- given program execution and to correspond to the method used in the - -- source programs. + function Image_Wide_Wide_Character (V : Wide_Wide_Character) return String; + -- Computes Wide_Wide_Character'Image (V) and returns the computed result end System.Img_WChar; diff --git a/gcc/ada/s-valwch.adb b/gcc/ada/s-valwch.adb index 8d4604552dc..6f2938f036f 100644 --- a/gcc/ada/s-valwch.adb +++ b/gcc/ada/s-valwch.adb @@ -33,8 +33,6 @@ with Interfaces; use Interfaces; with System.Val_Util; use System.Val_Util; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_StW; use System.WCh_StW; package body System.Val_WChar is @@ -43,15 +41,14 @@ package body System.Val_WChar is -------------------------- function Value_Wide_Character - (Str : String; - EM : WC_Encoding_Method) return Wide_Character + (Str : String) return Wide_Character is - WWC : constant Wide_Wide_Character := - Value_Wide_Wide_Character (Str, EM); - WWV : constant Unsigned_32 := Wide_Wide_Character'Pos (WWC); + WWC : constant Wide_Wide_Character := Value_Wide_Wide_Character (Str); + WWV : constant Unsigned_32 := Wide_Wide_Character'Pos (WWC); begin if WWV > 16#FFFF# then - raise Constraint_Error; + raise Constraint_Error + with "out of range character for Value attribute"; else return Wide_Character'Val (WWV); end if; @@ -62,8 +59,7 @@ package body System.Val_WChar is ------------------------------- function Value_Wide_Wide_Character - (Str : String; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character + (Str : String) return Wide_Wide_Character is F : Natural; L : Natural; @@ -81,48 +77,47 @@ package body System.Val_WChar is if L - F = 2 then return Wide_Wide_Character'Val (Character'Pos (S (F + 1))); - -- Otherwise must be a wide character in quotes. The easiest - -- thing is to convert the string to a wide wide string and then - -- pick up the single character that it should contain. + -- Otherwise something is very wrong else - declare - WS : constant Wide_Wide_String := - String_To_Wide_Wide_String (S (F + 1 .. L - 1), EM); - - begin - if WS'Length /= 1 then - raise Constraint_Error; - else - return WS (WS'First); - end if; - end; + raise Constraint_Error with "invalid string for Value attribute"; end if; - -- the last two values of the type have language-defined names: + -- Deal with Hex_hhhhhhhh cases for wide_[wide_]character cases - elsif S = "FFFE" then - return Wide_Wide_Character'Val (16#FFFE#); + elsif Str'Length = 12 and then Str (1 .. 4) = "Hex_" then + declare + W : Unsigned_32 := 0; - elsif S = "FFFF" then - return Wide_Wide_Character'Val (16#FFFF#); + begin + for J in 5 .. 12 loop + W := W * 16 + Character'Pos (Str (J)); - -- Otherwise must be a control character + if Str (J) in '0' .. '9' then + W := W - Character'Pos ('0'); + elsif Str (J) in 'A' .. 'F' then + W := W - Character'Pos ('A') + 10; + elsif Str (J) in 'a' .. 'f' then + W := W - Character'Pos ('a') + 10; + else + raise Constraint_Error + with "illegal hex character for Value attribute"; + end if; + end loop; - else - for C in Character'Val (16#00#) .. Character'Val (16#1F#) loop - if S (F .. L) = Character'Image (C) then - return Wide_Wide_Character'Val (Character'Pos (C)); + if W > 16#7FFF_FFFF# then + raise Constraint_Error + with "out of range value for Value attribute"; + else + return Wide_Wide_Character'Val (W); end if; - end loop; + end; - for C in Character'Val (16#7F#) .. Character'Val (16#9F#) loop - if S (F .. L) = Character'Image (C) then - return Wide_Wide_Character'Val (Character'Pos (C)); - end if; - end loop; + -- Otherwise must be one of the special names for Character - raise Constraint_Error; + else + return + Wide_Wide_Character'Val (Character'Pos (Character'Value (Str))); end if; end Value_Wide_Wide_Character; diff --git a/gcc/ada/s-valwch.ads b/gcc/ada/s-valwch.ads index 5075f756c2e..c3cc1e18d12 100644 --- a/gcc/ada/s-valwch.ads +++ b/gcc/ada/s-valwch.ads @@ -33,19 +33,15 @@ -- Processing for Wide_[Wide_]Value attribute -with System.WCh_Con; - package System.Val_WChar is pragma Pure (Val_WChar); function Value_Wide_Character - (Str : String; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character; - -- Computes Wide_Character'Value (Str). + (Str : String) return Wide_Character; + -- Computes Wide_Character'Value (Str) function Value_Wide_Wide_Character - (Str : String; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character; - -- Computes Wide_Character'Value (Str). + (Str : String) return Wide_Wide_Character; + -- Computes Wide_Character'Value (Str) end System.Val_WChar; diff --git a/gcc/ada/s-widwch.adb b/gcc/ada/s-widwch.adb index 3797bf52c99..72f03a3fb86 100644 --- a/gcc/ada/s-widwch.adb +++ b/gcc/ada/s-widwch.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUNTIME COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . W I D _ W C H A R -- -- -- @@ -31,8 +31,6 @@ -- -- ------------------------------------------------------------------------------ -with System.WCh_Con; use System.WCh_Con; - package body System.Wid_WChar is -------------------------- @@ -40,8 +38,7 @@ package body System.Wid_WChar is -------------------------- function Width_Wide_Character - (Lo, Hi : Wide_Character; - EM : WC_Encoding_Method) return Natural + (Lo, Hi : Wide_Character) return Natural is W : Natural; P : Natural; @@ -52,36 +49,12 @@ package body System.Wid_WChar is P := Wide_Character'Pos (C); -- Here if we find a character in wide character range + -- Width is max value (12) for Hex_hhhhhhhh if P > 16#FF# then + return 12; - case EM is - - when WCEM_Hex => - return Natural'Max (W, 5); - - when WCEM_Upper => - return Natural'Max (W, 2); - - when WCEM_Shift_JIS => - return Natural'Max (W, 2); - - when WCEM_EUC => - return Natural'Max (W, 2); - - when WCEM_UTF8 => - if Hi > Wide_Character'Val (16#07FF#) then - return Natural'Max (W, 3); - else - return Natural'Max (W, 2); - end if; - - when WCEM_Brackets => - return Natural'Max (W, 8); - - end case; - - -- If we are in character range then use length of character image + -- If we are in character range then use length of character image else declare @@ -100,8 +73,7 @@ package body System.Wid_WChar is ------------------------------- function Width_Wide_Wide_Character - (Lo, Hi : Wide_Wide_Character; - EM : WC_Encoding_Method) return Natural + (Lo, Hi : Wide_Wide_Character) return Natural is W : Natural; P : Natural; @@ -111,35 +83,11 @@ package body System.Wid_WChar is for C in Lo .. Hi loop P := Wide_Wide_Character'Pos (C); - -- Here if we find a character in wide wide character range + -- Here if we find a character in wide wide character range. + -- Width is max value (12) for Hex_hhhhhhhh if P > 16#FF# then - case EM is - when WCEM_Hex => - return Natural'Max (W, 5); - - when WCEM_Upper => - return Natural'Max (W, 2); - - when WCEM_Shift_JIS => - return Natural'Max (W, 2); - - when WCEM_EUC => - return Natural'Max (W, 2); - - when WCEM_UTF8 => - if Hi > Wide_Wide_Character'Val (16#FFFF#) then - return Natural'Max (W, 4); - elsif Hi > Wide_Wide_Character'Val (16#07FF#) then - return Natural'Max (W, 3); - else - return Natural'Max (W, 2); - end if; - - when WCEM_Brackets => - return Natural'Max (W, 10); - - end case; + W := 12; -- If we are in character range then use length of character image diff --git a/gcc/ada/s-widwch.ads b/gcc/ada/s-widwch.ads index 15c8705053d..6d79aae6f9b 100644 --- a/gcc/ada/s-widwch.ads +++ b/gcc/ada/s-widwch.ads @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUNTIME COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . W I D _ W C H A R -- -- -- @@ -33,21 +33,16 @@ -- This package contains the routines used for Wide_[Wide_]Character'Width -with System.WCh_Con; - package System.Wid_WChar is pragma Pure (Wid_WChar); function Width_Wide_Character - (Lo, Hi : Wide_Character; - EM : System.WCh_Con.WC_Encoding_Method) return Natural; + (Lo, Hi : Wide_Character) return Natural; -- Compute Width attribute for non-static type derived from Wide_Character. - -- The arguments are the low and high bounds for the type. EM is the - -- wide-character encoding method. + -- The arguments are the low and high bounds for the type. function Width_Wide_Wide_Character - (Lo, Hi : Wide_Wide_Character; - EM : System.WCh_Con.WC_Encoding_Method) return Natural; + (Lo, Hi : Wide_Wide_Character) return Natural; -- Same function for type derived from Wide_Wide_Character end System.Wid_WChar; diff --git a/gcc/ada/s-wwdcha.adb b/gcc/ada/s-wwdcha.adb index 82db6f39758..4fdf48fc685 100644 --- a/gcc/ada/s-wwdcha.adb +++ b/gcc/ada/s-wwdcha.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUNTIME COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . W W D _ C H A R -- -- -- @@ -43,11 +43,20 @@ package body System.WWd_Char is begin W := 0; for C in Lo .. Hi loop - declare - S : constant Wide_String := Character'Wide_Image (C); - begin - W := Natural'Max (W, S'Length); - end; + -- For Character range, use length of image + + if Character'Pos (C) < 256 then + declare + S : constant Wide_String := Character'Wide_Image (C); + begin + W := Natural'Max (W, S'Length); + end; + + -- For wide character, always max out at 12 (Hex_hhhhhhhh) + + else + return 12; + end if; end loop; return W; @@ -63,11 +72,21 @@ package body System.WWd_Char is begin W := 0; for C in Lo .. Hi loop - declare - S : constant Wide_Wide_String := Character'Wide_Wide_Image (C); - begin - W := Natural'Max (W, S'Length); - end; + + -- For Character range, use length of image + + if Character'Pos (C) < 256 then + declare + S : constant String := Character'Image (C); + begin + W := Natural'Max (W, S'Length); + end; + + -- For wide character, always max out at 12 (Hex_hhhhhhhh) + + else + return 12; + end if; end loop; return W; diff --git a/gcc/ada/s-wwdwch.adb b/gcc/ada/s-wwdwch.adb index ac3d1e9cc45..a87fd2c11c0 100644 --- a/gcc/ada/s-wwdwch.adb +++ b/gcc/ada/s-wwdwch.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUNTIME COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . W W D _ W C H A R -- -- -- @@ -59,7 +59,6 @@ package body System.Wwd_WChar is function Wide_Wide_Width_Wide_Wide_Char (Lo, Hi : Wide_Wide_Character) return Natural is - W : Natural := 0; LV : constant Unsigned_32 := Wide_Wide_Character'Pos (Lo); HV : constant Unsigned_32 := Wide_Wide_Character'Pos (Hi); @@ -68,36 +67,22 @@ package body System.Wwd_WChar is if LV > HV then return 0; - end if; + + -- Return max value (12) for wide character (Hex_hhhhhhhh) + + elsif HV > 255 then + return 12; -- If any characters in normal character range, then use normal -- Wide_Wide_Width attribute on this range to find out a starting point. -- Otherwise start with zero. - if LV <= 255 then - W := + else + return System.WWd_Char.Wide_Wide_Width_Character (Lo => Character'Val (LV), Hi => Character'Val (Unsigned_32'Min (255, HV))); - else - W := 0; end if; - - -- Increase to at least 4 if FFFE or FFFF present. These correspond - -- to the special language defined names FFFE/FFFF for these values. - - if 16#FFFF# in LV .. HV or else 16#FFFE# in LV .. HV then - W := Natural'Max (W, 4); - end if; - - -- Increase to at least 3 if any wide characters, corresponding to - -- the normal ' character ' sequence. We know that the character fits. - - if HV > 255 then - W := Natural'Max (W, 3); - end if; - - return W; end Wide_Wide_Width_Wide_Wide_Char; ------------------------------- @@ -107,7 +92,6 @@ package body System.Wwd_WChar is function Wide_Width_Wide_Character (Lo, Hi : Wide_Character) return Natural is - W : Natural := 0; LV : constant Unsigned_32 := Wide_Character'Pos (Lo); HV : constant Unsigned_32 := Wide_Character'Pos (Hi); @@ -116,62 +100,33 @@ package body System.Wwd_WChar is if LV > HV then return 0; - end if; + + -- Return max value (12) for wide character (Hex_hhhhhhhh) + + elsif HV > 255 then + return 12; -- If any characters in normal character range, then use normal -- Wide_Wide_Width attribute on this range to find out a starting point. -- Otherwise start with zero. - if LV <= 255 then - W := + else + return System.WWd_Char.Wide_Width_Character (Lo => Character'Val (LV), Hi => Character'Val (Unsigned_32'Min (255, HV))); - else - W := 0; - end if; - - -- Increase to at least 4 if FFFE or FFFF present. These correspond - -- to the special language defined names FFFE/FFFF for these values. - - if 16#FFFF# in LV .. HV or else 16#FFFE# in LV .. HV then - W := Natural'Max (W, 4); end if; - - -- Increase to at least 3 if any wide characters, corresponding to - -- the normal 'character' sequence. We know that the character fits. - - if HV > 255 then - W := Natural'Max (W, 3); - end if; - - return W; end Wide_Width_Wide_Character; ------------------------------------ -- Wide_Width_Wide_Wide_Character -- ------------------------------------ - -- This is a nasty case, because we get into the business of representing - -- out of range wide wide characters as wide strings. Let's let image do - -- the work here. Too bad if this takes lots of time. It's silly anyway! - function Wide_Width_Wide_Wide_Character (Lo, Hi : Wide_Wide_Character) return Natural is - W : Natural; - begin - W := 0; - for J in Lo .. Hi loop - declare - S : constant Wide_String := Wide_Wide_Character'Wide_Image (J); - begin - W := Natural'Max (W, S'Length); - end; - end loop; - - return W; + return Wide_Wide_Width_Wide_Wide_Char (Lo, Hi); end Wide_Width_Wide_Wide_Character; end System.Wwd_WChar; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f10ec25c707..315fada0bd2 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,6 @@ with Checks; use Checks; with Einfo; use Einfo; with Errout; use Errout; with Eval_Fat; -with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Expander; use Expander; with Freeze; use Freeze; @@ -66,7 +65,6 @@ with Ttypef; use Ttypef; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; -with Widechar; use Widechar; package body Sem_Attr is @@ -381,8 +379,7 @@ package body Sem_Attr is It : Interp; function Get_Kind (E : Entity_Id) return Entity_Kind; - -- Distinguish between access to regular and protected - -- subprograms. + -- Distinguish between access to regular/protected subprograms -------------- -- Get_Kind -- @@ -404,18 +401,20 @@ package body Sem_Attr is -- subprogram itself as the designated type. Type-checking in -- this case compares the signatures of the designated types. + Set_Etype (N, Any_Type); + if not Is_Overloaded (P) then - Acc_Type := - New_Internal_Entity - (Get_Kind (Entity (P)), Current_Scope, Loc, 'A'); - Set_Etype (Acc_Type, Acc_Type); - Set_Directly_Designated_Type (Acc_Type, Entity (P)); - Set_Etype (N, Acc_Type); + if not Is_Intrinsic_Subprogram (Entity (P)) then + Acc_Type := + New_Internal_Entity + (Get_Kind (Entity (P)), Current_Scope, Loc, 'A'); + Set_Etype (Acc_Type, Acc_Type); + Set_Directly_Designated_Type (Acc_Type, Entity (P)); + Set_Etype (N, Acc_Type); + end if; else Get_First_Interp (P, Index, It); - Set_Etype (N, Any_Type); - while Present (It.Nam) loop if not Is_Intrinsic_Subprogram (It.Nam) then Acc_Type := @@ -428,10 +427,10 @@ package body Sem_Attr is Get_Next_Interp (Index, It); end loop; + end if; - if Etype (N) = Any_Type then - Error_Attr ("prefix of % attribute cannot be intrinsic", P); - end if; + if Etype (N) = Any_Type then + Error_Attr ("prefix of % attribute cannot be intrinsic", P); end if; end Build_Access_Subprogram_Type; @@ -457,6 +456,12 @@ package body Sem_Attr is Check_Restriction (No_Implicit_Dynamic_Code, P); end if; + if Is_Always_Inlined (Entity (P)) then + Error_Attr + ("prefix of % attribute cannot be Inline_Always subprogram", + P); + end if; + -- Build the appropriate subprogram type Build_Access_Subprogram_Type (P); @@ -630,7 +635,7 @@ package body Sem_Attr is Index : Entity_Id; D : Int; - -- Dimension number for array attributes. + -- Dimension number for array attributes begin -- Case of string literal or string literal subtype. These cases @@ -703,7 +708,7 @@ package body Sem_Attr is procedure Check_Array_Type is D : Int; - -- Dimension number for array attributes. + -- Dimension number for array attributes begin -- If the type is a string literal type, then this must be generated @@ -1217,7 +1222,6 @@ package body Sem_Attr is procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is Etyp : Entity_Id; Btyp : Entity_Id; - begin Validate_Non_Static_Attribute_Function_Call; @@ -1247,17 +1251,24 @@ package body Sem_Attr is -- attribute reference was generated by the expander (in which -- case the underlying type will be used, as described in Sinfo), -- or the attribute was specified explicitly for the type itself - -- or one of its ancestors. + -- or one of its ancestors (taking visibility rules into account if + -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp + -- (with no visibility restriction). - if Is_Limited_Type (P_Type) - and then Comes_From_Source (N) - and then not Present (Find_Inherited_TSS (Btyp, Nam)) + if Comes_From_Source (N) + and then not Stream_Attribute_Available (P_Type, Nam) and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) then Error_Msg_Name_1 := Aname; - Error_Msg_NE - ("limited type& has no% attribute", P, Btyp); - Explain_Limited_Type (P_Type, P); + + if Is_Limited_Type (P_Type) then + Error_Msg_NE + ("limited type& has no% attribute", P, P_Type); + Explain_Limited_Type (P_Type, P); + else + Error_Msg_NE + ("attribute% for type& is not available", P, P_Type); + end if; end if; -- Check for violation of restriction No_Stream_Attributes @@ -1629,7 +1640,11 @@ package body Sem_Attr is end if; end if; - if Is_Overloaded (P) + -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current + -- output compiling in Ada 95 mode + + if Ada_Version < Ada_05 + and then Is_Overloaded (P) and then Aname /= Name_Access and then Aname /= Name_Address and then Aname /= Name_Code_Address @@ -1637,6 +1652,51 @@ package body Sem_Attr is and then Aname /= Name_Unchecked_Access then Error_Attr ("ambiguous prefix for % attribute", P); + + elsif Ada_Version >= Ada_05 + and then Is_Overloaded (P) + and then Aname /= Name_Access + and then Aname /= Name_Address + and then Aname /= Name_Code_Address + and then Aname /= Name_Unchecked_Access + then + -- Ada 2005 (AI-345): Since protected and task types have primitive + -- entry wrappers, the attributes Count, Caller and AST_Entry require + -- a context check + + if Ada_Version >= Ada_05 + and then (Aname = Name_Count + or else Aname = Name_Caller + or else Aname = Name_AST_Entry) + then + declare + Count : Natural := 0; + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (P, I, It); + + while Present (It.Nam) loop + if Comes_From_Source (It.Nam) then + Count := Count + 1; + else + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + + if Count > 1 then + Error_Attr ("ambiguous prefix for % attribute", P); + else + Set_Is_Overloaded (P, False); + end if; + end; + + else + Error_Attr ("ambiguous prefix for % attribute", P); + end if; end if; -- Remaining processing depends on attribute @@ -1692,6 +1752,20 @@ package body Sem_Attr is Set_Address_Taken (Ent); + -- An Address attribute is accepted when generated by + -- the compiler for dispatching operation, and an error + -- is issued once the subprogram is frozen (to avoid + -- confusing errors about implicit uses of Address in + -- the dispatch table initialization). + + if Is_Always_Inlined (Entity (P)) + and then Comes_From_Source (P) + then + Error_Attr + ("prefix of % attribute cannot be Inline_Always" & + " subprogram", P); + end if; + elsif Is_Object (Ent) or else Ekind (Ent) = E_Label then @@ -1973,7 +2047,7 @@ package body Sem_Attr is Attribute_Name => Name_Base), Expression => Relocate_Node (E1))); - -- E1 may be overloaded, and its interpretations preserved. + -- E1 may be overloaded, and its interpretations preserved Save_Interps (E1, Expression (N)); Analyze (N); @@ -2413,6 +2487,14 @@ package body Sem_Attr is if It.Nam = Ent then null; + -- Ada 2005 (AI-345): Do not consider primitive entry + -- wrappers generated for task or protected types. + + elsif Ada_Version >= Ada_05 + and then not Comes_From_Source (It.Nam) + then + null; + else Error_Attr ("ambiguous entry name", N); end if; @@ -3496,7 +3578,7 @@ package body Sem_Attr is if Is_Real_Type (P_Type) then null; - -- If not modular type, test for overflow check required. + -- If not modular type, test for overflow check required else if not Is_Modular_Integer_Type (P_Type) @@ -3941,7 +4023,7 @@ package body Sem_Attr is P : constant Node_Id := Prefix (N); C_Type : constant Entity_Id := Etype (N); - -- The type imposed by the context. + -- The type imposed by the context E1 : Node_Id; -- First expression, or Empty if none @@ -6303,19 +6385,10 @@ package body Sem_Attr is for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop - -- Assume all wide-character escape sequences are - -- same length, so we can quit when we reach one. - - -- Is this right for UTF-8? + -- All wide characters look like Hex_hhhhhhhh if J > 255 then - if Id = Attribute_Wide_Width then - W := Int'Max (W, 3); - exit; - else - W := Int'Max (W, Length_Wide); - exit; - end if; + W := 12; else C := Character'Val (J); @@ -6879,9 +6952,7 @@ package body Sem_Attr is -- enclosing composite type. if Ada_Version >= Ada_05 - and then Ekind (Btyp) = E_Anonymous_Access_Type - and then (Is_Array_Type (Scope (Btyp)) - or else Ekind (Scope (Btyp)) = E_Record_Type) + and then Is_Local_Anonymous_Access (Btyp) and then Object_Access_Level (P) > Type_Access_Level (Btyp) then -- In an instance, this is a runtime check, but one we @@ -7466,4 +7537,108 @@ package body Sem_Attr is Eval_Attribute (N); end Resolve_Attribute; + -------------------------------- + -- Stream_Attribute_Available -- + -------------------------------- + + function Stream_Attribute_Available + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Partial_View : Node_Id := Empty) return Boolean + is + Etyp : Entity_Id := Typ; + + function Has_Specified_Stream_Attribute + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Boolean; + -- True iff there is a visible attribute definition clause specifying + -- attribute Nam for Typ. + + ------------------------------------ + -- Has_Specified_Stream_Attribute -- + ------------------------------------ + + function Has_Specified_Stream_Attribute + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Boolean + is + begin + return False + or else + (Nam = TSS_Stream_Input + and then Has_Specified_Stream_Input (Typ)) + or else + (Nam = TSS_Stream_Output + and then Has_Specified_Stream_Output (Typ)) + or else + (Nam = TSS_Stream_Read + and then Has_Specified_Stream_Read (Typ)) + or else + (Nam = TSS_Stream_Write + and then Has_Specified_Stream_Write (Typ)); + end Has_Specified_Stream_Attribute; + + -- Start of processing for Stream_Attribute_Available + + begin + -- We need some comments in this body ??? + + if Has_Specified_Stream_Attribute (Typ, Nam) then + return True; + end if; + + if Is_Class_Wide_Type (Typ) then + return not Is_Limited_Type (Typ) + or else Stream_Attribute_Available (Etype (Typ), Nam); + end if; + + if Nam = TSS_Stream_Input + and then Is_Abstract (Typ) + and then not Is_Class_Wide_Type (Typ) + then + return False; + end if; + + if not (Is_Limited_Type (Typ) + or else (Present (Partial_View) + and then Is_Limited_Type (Partial_View))) + then + return True; + end if; + + if Nam = TSS_Stream_Input then + return Ada_Version >= Ada_05 + and then Stream_Attribute_Available (Etyp, TSS_Stream_Read); + elsif Nam = TSS_Stream_Output then + return Ada_Version >= Ada_05 + and then Stream_Attribute_Available (Etyp, TSS_Stream_Write); + end if; + + -- Case of Read and Write: check for attribute definition clause that + -- applies to an ancestor type. + + while Etype (Etyp) /= Etyp loop + Etyp := Etype (Etyp); + + if Has_Specified_Stream_Attribute (Etyp, Nam) then + return True; + end if; + end loop; + + if Ada_Version < Ada_05 then + + -- In Ada 95 mode, also consider a non-visible definition + + declare + Btyp : constant Entity_Id := Implementation_Base_Type (Typ); + begin + return Btyp /= Typ + and then Stream_Attribute_Available + (Btyp, Nam, Partial_View => Typ); + end; + end if; + + return False; + end Stream_Attribute_Available; + end Sem_Attr; diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 32e3eda9154..2a2c7b42917 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,8 +31,9 @@ -- This spec also documents all GNAT implementation defined pragmas -with Snames; use Snames; -with Types; use Types; +with Exp_Tss; use Exp_Tss; +with Snames; use Snames; +with Types; use Types; package Sem_Attr is @@ -54,20 +55,18 @@ package Sem_Attr is ------------------ Attribute_Abort_Signal => True, - -- - -- Standard'Abort_Signal (Standard is the only allowed prefix) - -- provides the entity for the special exception used to signal - -- task abort or asynchronous transfer of control. Normally this - -- attribute should only be used in the tasking runtime (it is - -- highly peculiar, and completely outside the normal semantics - -- of Ada, for a user program to intercept the abort exception). + -- Standard'Abort_Signal (Standard is the only allowed prefix) provides + -- the entity for the special exception used to signal task abort or + -- asynchronous transfer of control. Normally this attribute should only + -- be used in the tasking runtime (it is highly peculiar, and completely + -- outside the normal semantics of Ada, for a user program to intercept + -- the abort exception). ------------------ -- Address_Size -- ------------------ Attribute_Address_Size => True, - -- -- Standard'Address_Size (Standard is the only allowed prefix) is -- a static constant giving the number of bits in an Address. It -- is used primarily for constructing the definition of Memory_Size @@ -79,7 +78,6 @@ package Sem_Attr is --------------- Attribute_Asm_Input => True, - -- -- Used only in conjunction with the Asm and Asm_Volatile subprograms -- in package Machine_Code to construct machine instructions. See -- documentation in package Machine_Code in file s-maccod.ads. @@ -89,7 +87,6 @@ package Sem_Attr is ---------------- Attribute_Asm_Output => True, - -- -- Used only in conjunction with the Asm and Asm_Volatile subprograms -- in package Machine_Code to construct machine instructions. See -- documentation in package Machine_Code in file s-maccod.ads. @@ -99,7 +96,6 @@ package Sem_Attr is --------------- Attribute_AST_Entry => True, - -- -- E'Ast_Entry, where E is a task entry, yields a value of the -- predefined type System.DEC.AST_Handler, that enables the given -- entry to be called when an AST occurs. If the name to which the @@ -117,20 +113,19 @@ package Sem_Attr is --------- Attribute_Bit => True, - -- - -- Obj'Bit, where Obj is any object, yields the bit offset within - -- the storage unit (byte) that contains the first bit of storage - -- allocated for the object. The value of this attribute is of the - -- type Universal_Integer, and is always a non-negative number not - -- exceeding the value of System.Storage_Unit. + -- Obj'Bit, where Obj is any object, yields the bit offset within the + -- storage unit (byte) that contains the first bit of storage allocated + -- for the object. The attribute value is of type Universal_Integer, + -- and is always a non-negative number not exceeding the value of + -- System.Storage_Unit. -- -- For an object that is a variable or a constant allocated in a -- register, the value is zero. (The use of this attribute does not -- force the allocation of a variable to memory). -- - -- For an object that is a formal parameter, this attribute applies - -- to either the matching actual parameter or to a copy of the - -- matching actual parameter. + -- For an object that is a formal parameter, this attribute applies to + -- either the matching actual parameter or to a copy of the matching + -- actual parameter. -- -- For an access object the value is zero. Note that Obj.all'Bit is -- subject to an Access_Check for the designated object. Similarly @@ -145,22 +140,20 @@ package Sem_Attr is ------------------ Attribute_Code_Address => True, - -- - -- subp'Code_Address, where subp is a subprogram entity, gives the - -- address of the first generated instruction for a subprogram. This - -- is often, but not always the same as the 'Address value, which is - -- the address to be used in a call. The differences occur in the case - -- of a nested procedure (where Address yields the address of the - -- trampoline code used to load the static link), and on some systems - -- which use procedure descriptors (in which case Address yields the - -- address of the descriptor). + -- The reference subp'Code_Address, where subp is a subprogram entity, + -- gives the address of the first generated instruction for the sub- + -- program. This is often, but not always the same as the 'Address + -- value, which is the address to be used in a call. The differences + -- occur in the case of a nested procedure (where Address yields the + -- address of the trampoline code used to load the static link), and on + -- some systems which use procedure descriptors (in which case Address + -- yields the address of the descriptor). ----------------------- -- Default_Bit_Order -- ----------------------- Attribute_Default_Bit_Order => True, - -- -- Standard'Default_Bit_Order (Standard is the only permissible prefix), -- provides the value System.Default_Bit_Order as a Pos value (0 for -- High_Order_First, 1 for Low_Order_First). This is used to construct @@ -172,22 +165,20 @@ package Sem_Attr is --------------- Attribute_Elab_Body => True, - -- - -- This attribute can only be applied to a program unit name. It - -- returns the entity for the corresponding elaboration procedure - -- for elaborating the body of the referenced unit. This is used - -- in the main generated elaboration procedure by the binder, and - -- is not normally used in any other context, but there may be - -- specialized situations in which it is useful to be able to - -- call this elaboration procedure from Ada code, e.g. if it - -- is necessary to do selective reelaboration to fix some error. + -- This attribute can only be applied to a program unit name. It returns + -- the entity for the corresponding elaboration procedure for elabor- + -- ating the body of the referenced unit. This is used in the main + -- generated elaboration procedure by the binder, and is not normally + -- used in any other context, but there may be specialized situations in + -- which it is useful to be able to call this elaboration procedure from + -- Ada code, e.g. if it is necessary to do selective reelaboration to + -- fix some error. --------------- -- Elab_Spec -- --------------- Attribute_Elab_Spec => True, - -- -- This attribute can only be applied to a program unit name. It -- returns the entity for the corresponding elaboration procedure -- for elaborating the spec of the referenced unit. This is used @@ -202,7 +193,6 @@ package Sem_Attr is ---------------- Attribute_Elaborated => True, - -- -- Lunit'Elaborated, where Lunit is a library unit, yields a boolean -- value indicating whether or not the body of the designated library -- unit has been elaborated yet. @@ -212,7 +202,6 @@ package Sem_Attr is -------------- Attribute_Enum_Rep => True, - -- -- For every enumeration subtype S, S'Enum_Rep denotes a function -- with the following specification: -- @@ -228,7 +217,6 @@ package Sem_Attr is ----------------- Attribute_Fixed_Value => True, - -- -- For every fixed-point type S, S'Fixed_Value denotes a function -- with the following specification: -- @@ -238,18 +226,17 @@ package Sem_Attr is -- -- V = Arg * S'Small -- - -- The effect is thus equivalent to first converting the argument - -- to the integer type used to represent S, and then doing an - -- unchecked conversion to the fixed-point type. This attribute is - -- primarily intended for use in implementation of the input-output - -- functions for fixed-point values. + -- The effect is thus equivalent to first converting the argument to + -- the integer type used to represent S, and then doing an unchecked + -- conversion to the fixed-point type. This attribute is primarily + -- intended for use in implementation of the input-output functions for + -- fixed-point values. ----------------------- -- Has_Discriminants -- ----------------------- Attribute_Has_Discriminants => True, - -- -- Gtyp'Has_Discriminants, where Gtyp is a generic formal type, yields -- a Boolean value indicating whether or not the actual instantiation -- type has discriminants. @@ -259,7 +246,6 @@ package Sem_Attr is --------- Attribute_Img => True, - -- -- The 'Img function is defined for any prefix, P, that denotes an -- object of scalar type T. P'Img is equivalent to T'Image (P). This -- is convenient for debugging. For example: @@ -277,7 +263,6 @@ package Sem_Attr is ------------------- Attribute_Integer_Value => True, - -- -- For every integer type S, S'Integer_Value denotes a function -- with the following specification: -- @@ -298,7 +283,6 @@ package Sem_Attr is ------------------ Attribute_Machine_Size => True, - -- -- This attribute is identical to the Object_Size attribute. It is -- provided for compatibility with the DEC attribute of this name. @@ -307,7 +291,6 @@ package Sem_Attr is ----------------------- Attribute_Maximum_Alignment => True, - -- -- Standard'Maximum_Alignment (Standard is the only permissible prefix) -- provides the maximum useful alignment value for the target. This -- is a static value that can be used to specify the alignment for an @@ -320,7 +303,6 @@ package Sem_Attr is -------------------- Attribute_Mechanism_Code => True, - -- -- function'Mechanism_Code yeilds an integer code for the mechanism -- used for the result of function, and subprogram'Mechanism_Code (n) -- yields the mechanism used for formal parameter number n (a static @@ -342,64 +324,59 @@ package Sem_Attr is -------------------- Attribute_Null_Parameter => True, + -- A reference T'Null_Parameter denotes an (imaginary) object of type or + -- subtype T allocated at (machine) address zero. The attribute is + -- allowed only as the default expression of a formal parameter, or as + -- an actual expression of a subporgram call. In either case, the + -- subprogram must be imported. -- - -- A reference T'Null_Parameter denotes an (imaginary) object of - -- type or subtype T allocated at (machine) address zero. The - -- attribute is allowed only as the default expression of a formal - -- parameter, or as an actual expression of a subporgram call. In - -- either case, the subprogram must be imported. - -- - -- The identity of the object is represented by the address zero - -- in the argument list, independent of the passing mechanism - -- (explicit or default). + -- The identity of the object is represented by the address zero in the + -- argument list, independent of the passing mechanism (explicit or + -- default). -- - -- The reason that this capability is needed is that for a record - -- or other composite object passed by reference, there is no other - -- way of specifying that a zero address should be passed. + -- The reason that this capability is needed is that for a record or + -- other composite object passed by reference, there is no other way of + -- specifying that a zero address should be passed. ----------------- -- Object_Size -- ----------------- Attribute_Object_Size => True, - -- -- Type'Object_Size is the same as Type'Size for all types except -- fixed-point types and discrete types. For fixed-point types and -- discrete types, this attribute gives the size used for default - -- allocation of objects and components of the size. See section - -- in Einfo ("Handling of type'Size values") for further details. + -- allocation of objects and components of the size. See section in + -- Einfo ("Handling of type'Size values") for further details. ------------------------- -- Passed_By_Reference -- ------------------------- Attribute_Passed_By_Reference => True, - -- - -- T'Passed_By_Reference for any subtype T returns a boolean value - -- that is true if the type is normally passed by reference and - -- false if the type is normally passed by copy in calls. For scalar - -- types, the result is always False and is static. For non-scalar - -- types, the result is non-static (since it is computed by Gigi). + -- T'Passed_By_Reference for any subtype T returns a boolean value that + -- is true if the type is normally passed by reference and false if the + -- type is normally passed by copy in calls. For scalar types, the + -- result is always False and is static. For non-scalar types, the + -- result is non-static (since it is computed by Gigi). ------------------ -- Range_Length -- ------------------ Attribute_Range_Length => True, - -- - -- T'Range_Length for any discrete type T yields the number of - -- values represented by the subtype (zero for a null range). The - -- result is static for static subtypes. Note that Range_Length - -- applied to the index subtype of a one dimensional array always - -- gives the same result as Range applied to the array itself. - -- The result is of type universal integer. + -- T'Range_Length for any discrete type T yields the number of values + -- represented by the subtype (zero for a null range). The result is + -- static for static subtypes. Note that Range_Length applied to the + -- index subtype of a one dimensional array always gives the same result + -- as Range applied to the array itself. The result is of type universal + -- integer. ------------------ -- Storage_Unit -- ------------------ Attribute_Storage_Unit => True, - -- -- Standard'Storage_Unit (Standard is the only permissible prefix) -- provides the value System.Storage_Unit, and is intended primarily -- for constructing this definition in package System (see note above @@ -410,36 +387,33 @@ package Sem_Attr is ----------------- Attribute_Target_Name => True, - -- - -- Standard'Target_Name yields the string identifying the target - -- for the compilation, taken from Sdefault.Target_Name. + -- Standard'Target_Name yields the string identifying the target for the + -- compilation, taken from Sdefault.Target_Name. ---------------- -- To_Address -- ---------------- Attribute_To_Address => True, - -- - -- System'To_Address (Address is the only permissible prefix) - -- is a function that takes any integer value, and converts it into - -- an address value. The semantics is to first convert the integer - -- value to type Integer_Address according to normal conversion - -- rules, and then to convert this to an address using the same - -- semantics as the System.Storage_Elements.To_Address function. - -- The important difference is that this is a static attribute - -- so it can be used in initializations in preealborate packages. + -- System'To_Address (Address is the only permissible prefix) is a + -- function that takes any integer value, and converts it into an + -- address value. The semantics is to first convert the integer value to + -- type Integer_Address according to normal conversion rules, and then + -- to convert this to an address using the same semantics as the + -- System.Storage_Elements.To_Address function. The important difference + -- is that this is a static attribute so it can be used in + -- initializations in preealborate packages. ---------------- -- Type_Class -- ---------------- Attribute_Type_Class => True, - -- - -- T'Type_Class for any type or subtype T yields the value of the - -- type class for the full type of T. If T is a generic formal type, - -- then the value is the value for the corresponding actual subtype. - -- The value of this attribute is of type System.Aux_DEC.Type_Class, - -- which has the following definition: + -- T'Type_Class for any type or subtype T yields the value of the type + -- class for the full type of T. If T is a generic formal type, then the + -- value is the value for the corresponding actual subtype. The value of + -- this attribute is of type System.Aux_DEC.Type_Class, which has the + -- following definition: -- -- type Type_Class is -- (Type_Class_Enumeration, @@ -452,9 +426,9 @@ package Sem_Attr is -- Type_Class_Task, -- Type_Class_Address); -- - -- Protected types yield the value Type_Class_Task, which thus - -- applies to all concurrent types. This attribute is designed to - -- be compatible with the DEC Ada attribute of the same name. + -- Protected types yield the value Type_Class_Task, which thus applies + -- to all concurrent types. This attribute is designed to be compatible + -- with the DEC Ada attribute of the same name. -- -- Note: if pragma Extend_System is used to merge the definitions of -- Aux_DEC into System, then the type Type_Class can be referenced @@ -465,7 +439,6 @@ package Sem_Attr is ----------------- Attribute_UET_Address => True, - -- -- Unit'UET_Address, where Unit is a program unit, yields the address -- of the unit exception table for the specified unit. This is only -- used in the internal implementation of exception handling. See the @@ -476,23 +449,21 @@ package Sem_Attr is ------------------------------ Attribute_Universal_Literal_String => True, - -- - -- The prefix of 'Universal_Literal_String must be a named number. - -- The static result is the string consisting of the characters of - -- the number as defined in the original source. This allows the - -- user program to access the actual text of named numbers without - -- intermediate conversions and without the need to enclose the - -- strings in quotes (which would preclude their use as numbers). - -- This is used internally for the construction of values of the - -- floating-point attributes from the file ttypef.ads, but may - -- also be used by user programs. + -- The prefix of 'Universal_Literal_String must be a named number. The + -- static result is the string consisting of the characters of the + -- number as defined in the original source. This allows the user + -- program to access the actual text of named numbers without + -- intermediate conversions and without the need to enclose the strings + -- in quotes (which would preclude their use as numbers). This is used + -- internally for the construction of values of the floating-point + -- attributes from the file ttypef.ads, but may also be used by user + -- programs. ------------------------- -- Unrestricted_Access -- ------------------------- Attribute_Unrestricted_Access => True, - -- -- The Unrestricted_Access attribute is similar to Access except that -- all accessibility and aliased view checks are omitted. This is very -- much a user-beware attribute. Basically its status is very similar @@ -510,32 +481,28 @@ package Sem_Attr is --------------- Attribute_VADS_Size => True, - -- - -- Typ'VADS_Size yields the Size value typically yielded by some - -- Ada 83 compilers. The differences between VADS_Size and Size - -- is that for scalar types for which no Size has been specified, - -- VADS_Size yields the Object_Size rather than the Value_Size. - -- For example, while Natural'Size is typically 31, the value of - -- Natural'VADS_Size is 32. For all other types, Size and VADS_Size - -- yield the same value. + -- Typ'VADS_Size yields the Size value typically yielded by some Ada 83 + -- compilers. The differences between VADS_Size and Size is that for + -- scalar types for which no Size has been specified, VADS_Size yields + -- the Object_Size rather than the Value_Size. For example, while + -- Natural'Size is typically 31, the value of Natural'VADS_Size is 32. + -- For all other types, Size and VADS_Size yield the same value. ---------------- -- Value_Size -- ---------------- Attribute_Value_Size => True, - -- - -- Type'Value_Size is the number of bits required to represent a - -- value of the given subtype. It is the same as Type'Size, but, - -- unlike Size, may be set for non-first subtypes. See section - -- in Einfo ("Handling of type'Size values") for further details. + -- Type'Value_Size is the number of bits required to represent value of + -- the given subtype. It is the same as Type'Size, but, unlike Size, may + -- be set for non-first subtypes. See section in Einfo ("Handling of + -- type'Size values") for further details. --------------- -- Word_Size -- --------------- Attribute_Word_Size => True, - -- -- Standard'Word_Size (Standard is the only permissible prefix) -- provides the value System.Word_Size, and is intended primarily -- for constructing this definition in package System (see note above @@ -554,14 +521,26 @@ package Sem_Attr is -- other attributes). procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id); - -- Performs type resolution of attribute. If the attribute yields - -- a universal value, mark its type as that of the context. On - -- the other hand, if the context itself is universal (as in - -- T'Val (T'Pos (X)), mark the type as being the largest type of - -- that class that can be used at run-time. This is correct since - -- either the value gets folded (in which case it doesn't matter - -- what type of the class we give if, since the folding uses universal - -- arithmetic anyway) or it doesn't get folded (in which case it is - -- going to be dealt with at runtime, and the largest type is right). + -- Performs type resolution of attribute. If the attribute yields a + -- universal value, mark its type as that of the context. On the other + -- hand, if the context itself is universal (as in T'Val (T'Pos (X)), mark + -- the type as being the largest type of that class that can be used at + -- run-time. This is correct since either the value gets folded (in which + -- case it doesn't matter what type of the class we give if, since the + -- folding uses universal arithmetic anyway) or it doesn't get folded (in + -- which case it is going to be dealt with at runtime, and the largest type + -- is right). + + function Stream_Attribute_Available + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Partial_View : Entity_Id := Empty) return Boolean; + -- For a limited type Typ, return True iff the given attribute is + -- available. For Ada 05, availability is defined by 13.13.2(36/1). For Ada + -- 95, an attribute is considered to be available if it has been specified + -- using an attribute definition clause for the type, or for its full view, + -- or for an ancestor of either. Parameter Partial_View is used only + -- internally, when checking for an attribute definition clause that is not + -- visible (Ada 95 only). end Sem_Attr; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9eeec66e3c0..10846a329fb 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -244,6 +244,137 @@ package body Sem_Ch13 is -- disallow Storage_Size for derived task types, but that is also -- clearly unintentional. + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); + -- Common processing for 'Read, 'Write, 'Input and 'Output attribute + -- definition clauses. + + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is + Subp : Entity_Id := Empty; + I : Interp_Index; + It : Interp; + Pnam : Entity_Id; + + Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read); + + function Has_Good_Profile (Subp : Entity_Id) return Boolean; + -- Return true if the entity is a subprogram with an appropriate + -- profile for the attribute being defined. + + ---------------------- + -- Has_Good_Profile -- + ---------------------- + + function Has_Good_Profile (Subp : Entity_Id) return Boolean is + F : Entity_Id; + Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input); + Expected_Ekind : constant array (Boolean) of Entity_Kind := + (False => E_Procedure, True => E_Function); + Typ : Entity_Id; + + begin + if Ekind (Subp) /= Expected_Ekind (Is_Function) then + return False; + end if; + + F := First_Formal (Subp); + + if No (F) + or else Ekind (Etype (F)) /= E_Anonymous_Access_Type + or else Designated_Type (Etype (F)) /= + Class_Wide_Type (RTE (RE_Root_Stream_Type)) + then + return False; + end if; + + if not Is_Function then + Next_Formal (F); + + declare + Expected_Mode : constant array (Boolean) of Entity_Kind := + (False => E_In_Parameter, + True => E_Out_Parameter); + begin + if Parameter_Mode (F) /= Expected_Mode (Is_Read) then + return False; + end if; + end; + + Typ := Etype (F); + + else + Typ := Etype (Subp); + end if; + + return Base_Type (Typ) = Base_Type (Ent) + and then No (Next_Formal (F)); + + end Has_Good_Profile; + + -- Start of processing for Analyze_Stream_TSS_Definition + + begin + FOnly := True; + + if not Is_Type (U_Ent) then + Error_Msg_N ("local name must be a subtype", Nam); + return; + end if; + + Pnam := TSS (Base_Type (U_Ent), TSS_Nam); + + if Present (Pnam) and then Has_Good_Profile (Pnam) then + Error_Msg_Sloc := Sloc (Pnam); + Error_Msg_Name_1 := Attr; + Error_Msg_N ("% attribute already defined #", Nam); + return; + end if; + + Analyze (Expr); + + if Is_Entity_Name (Expr) then + if not Is_Overloaded (Expr) then + if Has_Good_Profile (Entity (Expr)) then + Subp := Entity (Expr); + end if; + + else + Get_First_Interp (Expr, I, It); + + while Present (It.Nam) loop + if Has_Good_Profile (It.Nam) then + Subp := It.Nam; + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end if; + + if Present (Subp) then + if Is_Abstract (Subp) then + Error_Msg_N ("stream subprogram must not be abstract", Expr); + return; + end if; + + Set_Entity (Expr, Subp); + Set_Etype (Expr, Etype (Subp)); + + if TSS_Nam = TSS_Stream_Input then + New_Stream_Function (N, U_Ent, Subp, TSS_Nam); + else + New_Stream_Procedure (N, U_Ent, Subp, TSS_Nam, + Out_P => Is_Read); + end if; + + else + Error_Msg_Name_1 := Attr; + Error_Msg_N ("incorrect expression for% attribute", Expr); + end if; + end Analyze_Stream_TSS_Definition; + + -- Start of processing for Analyze_Attribute_Definition_Clause + begin Analyze (Nam); Ent := Entity (Nam); @@ -252,26 +383,26 @@ package body Sem_Ch13 is return; end if; - -- Rep clause applies to full view of incomplete type or private type - -- if we have one (if not, this is a premature use of the type). - -- However, certain semantic checks need to be done on the specified - -- entity (i.e. the private view), so we save it in Ent. + -- Rep clause applies to full view of incomplete type or private type if + -- we have one (if not, this is a premature use of the type). However, + -- certain semantic checks need to be done on the specified entity (i.e. + -- the private view), so we save it in Ent. if Is_Private_Type (Ent) and then Is_Derived_Type (Ent) and then not Is_Tagged_Type (Ent) and then No (Full_View (Ent)) then - -- If this is a private type whose completion is a derivation - -- from another private type, there is no full view, and the - -- attribute belongs to the type itself, not its underlying parent. + -- If this is a private type whose completion is a derivation from + -- another private type, there is no full view, and the attribute + -- belongs to the type itself, not its underlying parent. U_Ent := Ent; elsif Ekind (Ent) = E_Incomplete_Type then - -- The attribute applies to the full view, set the entity - -- of the attribute definition accordingly. + -- The attribute applies to the full view, set the entity of the + -- attribute definition accordingly. Ent := Underlying_Type (Ent); U_Ent := Ent; @@ -668,94 +799,9 @@ package body Sem_Ch13 is -- Input -- ----------- - when Attribute_Input => Input : declare - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; - - function Has_Good_Profile (Subp : Entity_Id) return Boolean; - -- Return true if the entity is a function with an appropriate - -- profile for the Input attribute. - - ---------------------- - -- Has_Good_Profile -- - ---------------------- - - function Has_Good_Profile (Subp : Entity_Id) return Boolean is - F : Entity_Id; - Ok : Boolean := False; - - begin - if Ekind (Subp) = E_Function then - F := First_Formal (Subp); - - if Present (F) and then No (Next_Formal (F)) then - if Ekind (Etype (F)) = E_Anonymous_Access_Type - and then - Designated_Type (Etype (F)) = - Class_Wide_Type (RTE (RE_Root_Stream_Type)) - then - Ok := Base_Type (Etype (Subp)) = Base_Type (Ent); - end if; - end if; - end if; - - return Ok; - end Has_Good_Profile; - - -- Start of processing for Input attribute definition - - begin - FOnly := True; - - if not Is_Type (U_Ent) then - Error_Msg_N ("local name must be a subtype", Nam); - return; - - else - Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Input); - - if Present (Pnam) - and then Base_Type (Etype (Pnam)) = Base_Type (U_Ent) - then - Error_Msg_Sloc := Sloc (Pnam); - Error_Msg_N ("input attribute already defined #", Nam); - return; - end if; - end if; - - Analyze (Expr); - - if Is_Entity_Name (Expr) then - if not Is_Overloaded (Expr) then - if Has_Good_Profile (Entity (Expr)) then - Subp := Entity (Expr); - end if; - - else - Get_First_Interp (Expr, I, It); - - while Present (It.Nam) loop - if Has_Good_Profile (It.Nam) then - Subp := It.Nam; - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - end if; - - if Present (Subp) then - Set_Entity (Expr, Subp); - Set_Etype (Expr, Etype (Subp)); - New_Stream_Function (N, U_Ent, Subp, TSS_Stream_Input); - else - Error_Msg_N ("incorrect expression for input attribute", Expr); - return; - end if; - end Input; + when Attribute_Input => + Analyze_Stream_TSS_Definition (TSS_Stream_Input); + Set_Has_Specified_Stream_Input (Ent); ------------------- -- Machine_Radix -- @@ -831,198 +877,17 @@ package body Sem_Ch13 is -- Output -- ------------ - when Attribute_Output => Output : declare - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; - - function Has_Good_Profile (Subp : Entity_Id) return Boolean; - -- Return true if the entity is a procedure with an - -- appropriate profile for the output attribute. - - ---------------------- - -- Has_Good_Profile -- - ---------------------- - - function Has_Good_Profile (Subp : Entity_Id) return Boolean is - F : Entity_Id; - Ok : Boolean := False; - - begin - if Ekind (Subp) = E_Procedure then - F := First_Formal (Subp); - - if Present (F) then - if Ekind (Etype (F)) = E_Anonymous_Access_Type - and then - Designated_Type (Etype (F)) = - Class_Wide_Type (RTE (RE_Root_Stream_Type)) - then - Next_Formal (F); - Ok := Present (F) - and then Parameter_Mode (F) = E_In_Parameter - and then Base_Type (Etype (F)) = Base_Type (Ent) - and then No (Next_Formal (F)); - end if; - end if; - end if; - - return Ok; - end Has_Good_Profile; - - -- Start of processing for Output attribute definition - - begin - FOnly := True; - - if not Is_Type (U_Ent) then - Error_Msg_N ("local name must be a subtype", Nam); - return; - - else - Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Output); - - if Present (Pnam) - and then - Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) - = Base_Type (U_Ent) - then - Error_Msg_Sloc := Sloc (Pnam); - Error_Msg_N ("output attribute already defined #", Nam); - return; - end if; - end if; - - Analyze (Expr); - - if Is_Entity_Name (Expr) then - if not Is_Overloaded (Expr) then - if Has_Good_Profile (Entity (Expr)) then - Subp := Entity (Expr); - end if; - - else - Get_First_Interp (Expr, I, It); - - while Present (It.Nam) loop - if Has_Good_Profile (It.Nam) then - Subp := It.Nam; - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - end if; - - if Present (Subp) then - Set_Entity (Expr, Subp); - Set_Etype (Expr, Etype (Subp)); - New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Output); - else - Error_Msg_N ("incorrect expression for output attribute", Expr); - return; - end if; - end Output; + when Attribute_Output => + Analyze_Stream_TSS_Definition (TSS_Stream_Output); + Set_Has_Specified_Stream_Output (Ent); ---------- -- Read -- ---------- - when Attribute_Read => Read : declare - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; - - function Has_Good_Profile (Subp : Entity_Id) return Boolean; - -- Return true if the entity is a procedure with an appropriate - -- profile for the Read attribute. - - ---------------------- - -- Has_Good_Profile -- - ---------------------- - - function Has_Good_Profile (Subp : Entity_Id) return Boolean is - F : Entity_Id; - Ok : Boolean := False; - - begin - if Ekind (Subp) = E_Procedure then - F := First_Formal (Subp); - - if Present (F) then - if Ekind (Etype (F)) = E_Anonymous_Access_Type - and then - Designated_Type (Etype (F)) = - Class_Wide_Type (RTE (RE_Root_Stream_Type)) - then - Next_Formal (F); - Ok := Present (F) - and then Parameter_Mode (F) = E_Out_Parameter - and then Base_Type (Etype (F)) = Base_Type (Ent) - and then No (Next_Formal (F)); - end if; - end if; - end if; - - return Ok; - end Has_Good_Profile; - - -- Start of processing for Read attribute definition - - begin - FOnly := True; - - if not Is_Type (U_Ent) then - Error_Msg_N ("local name must be a subtype", Nam); - return; - - else - Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Read); - - if Present (Pnam) - and then Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) - = Base_Type (U_Ent) - then - Error_Msg_Sloc := Sloc (Pnam); - Error_Msg_N ("read attribute already defined #", Nam); - return; - end if; - end if; - - Analyze (Expr); - - if Is_Entity_Name (Expr) then - if not Is_Overloaded (Expr) then - if Has_Good_Profile (Entity (Expr)) then - Subp := Entity (Expr); - end if; - - else - Get_First_Interp (Expr, I, It); - - while Present (It.Nam) loop - if Has_Good_Profile (It.Nam) then - Subp := It.Nam; - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - end if; - - if Present (Subp) then - Set_Entity (Expr, Subp); - Set_Etype (Expr, Etype (Subp)); - New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Read, True); - else - Error_Msg_N ("incorrect expression for read attribute", Expr); - return; - end if; - end Read; + when Attribute_Read => + Analyze_Stream_TSS_Definition (TSS_Stream_Read); + Set_Has_Specified_Stream_Read (Ent); ---------- -- Size -- @@ -1436,101 +1301,9 @@ package body Sem_Ch13 is -- Write -- ----------- - -- Write attribute definition clause - -- check for class-wide case will be performed later - - when Attribute_Write => Write : declare - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; - - function Has_Good_Profile (Subp : Entity_Id) return Boolean; - -- Return true if the entity is a procedure with an - -- appropriate profile for the write attribute. - - ---------------------- - -- Has_Good_Profile -- - ---------------------- - - function Has_Good_Profile (Subp : Entity_Id) return Boolean is - F : Entity_Id; - Ok : Boolean := False; - - begin - if Ekind (Subp) = E_Procedure then - F := First_Formal (Subp); - - if Present (F) then - if Ekind (Etype (F)) = E_Anonymous_Access_Type - and then - Designated_Type (Etype (F)) = - Class_Wide_Type (RTE (RE_Root_Stream_Type)) - then - Next_Formal (F); - Ok := Present (F) - and then Parameter_Mode (F) = E_In_Parameter - and then Base_Type (Etype (F)) = Base_Type (Ent) - and then No (Next_Formal (F)); - end if; - end if; - end if; - - return Ok; - end Has_Good_Profile; - - -- Start of processing for Write attribute definition - - begin - FOnly := True; - - if not Is_Type (U_Ent) then - Error_Msg_N ("local name must be a subtype", Nam); - return; - end if; - - Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Write); - - if Present (Pnam) - and then Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) - = Base_Type (U_Ent) - then - Error_Msg_Sloc := Sloc (Pnam); - Error_Msg_N ("write attribute already defined #", Nam); - return; - end if; - - Analyze (Expr); - - if Is_Entity_Name (Expr) then - if not Is_Overloaded (Expr) then - if Has_Good_Profile (Entity (Expr)) then - Subp := Entity (Expr); - end if; - - else - Get_First_Interp (Expr, I, It); - - while Present (It.Nam) loop - if Has_Good_Profile (It.Nam) then - Subp := It.Nam; - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - end if; - - if Present (Subp) then - Set_Entity (Expr, Subp); - Set_Etype (Expr, Etype (Subp)); - New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Write); - else - Error_Msg_N ("incorrect expression for write attribute", Expr); - return; - end if; - end Write; + when Attribute_Write => + Analyze_Stream_TSS_Definition (TSS_Stream_Write); + Set_Has_Specified_Stream_Write (Ent); -- All other attributes cannot be set diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 5660b1555a4..c8c4a272576 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1114,48 +1114,10 @@ package body Sem_Ch7 is Found_Explicit : Boolean; Decl_Privates : Boolean; - function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean; - -- Check whether a pragma Overriding has been provided for a primitive - -- operation that is found to be overriding in the private part. - function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean; -- Check whether an inherited subprogram is an operation of an -- untagged derived type. - --------------------------- - -- Has_Overriding_Pragma -- - --------------------------- - - function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean is - Decl : constant Node_Id := Unit_Declaration_Node (Subp); - Prag : Node_Id; - - begin - if No (Decl) - or else Nkind (Decl) /= N_Subprogram_Declaration - or else No (Next (Decl)) - then - return False; - - else - Prag := Next (Decl); - - while Present (Prag) - and then Nkind (Prag) = N_Pragma - loop - if Chars (Prag) = Name_Overriding - or else Chars (Prag) = Name_Optional_Overriding - then - return True; - else - Next (Prag); - end if; - end loop; - end if; - - return False; - end Has_Overriding_Pragma; - --------------------- -- Is_Primitive_Of -- --------------------- @@ -1238,20 +1200,9 @@ package body Sem_Ch7 is Replace_Elmt (Op_Elmt, New_Op); Remove_Elmt (Op_List, Op_Elmt_2); Found_Explicit := True; + Set_Is_Overriding_Operation (New_Op); Decl_Privates := True; - -- If explicit_overriding is in effect, check that - -- the overriding operation is properly labelled. - - if Explicit_Overriding - and then Comes_From_Source (New_Op) - and then not Has_Overriding_Pragma (New_Op) - then - Error_Msg_NE - ("Missing overriding pragma for&", - New_Op, New_Op); - end if; - exit; end if; @@ -1692,9 +1643,13 @@ package body Sem_Ch7 is Set_RM_Size (Priv, RM_Size (Full)); Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time (Full)); - Set_Is_Volatile (Priv, Is_Volatile (Full)); - Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); - Set_Is_Ada_2005 (Priv, Is_Ada_2005 (Full)); + Set_Is_Volatile (Priv, Is_Volatile (Full)); + Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); + Set_Is_Ada_2005 (Priv, Is_Ada_2005 (Full)); + + if Is_Unchecked_Union (Full) then + Set_Is_Unchecked_Union (Base_Type (Priv)); + end if; -- Why is atomic not copied here ??? if Referenced (Full) then @@ -1717,8 +1672,34 @@ package body Sem_Ch7 is and then not Error_Posted (Full) then if Priv_Is_Base_Type then - Set_Access_Disp_Table (Priv, Access_Disp_Table - (Base_Type (Full))); + + -- Ada 2005 (AI-345): The full view of a type implementing + -- an interface can be a task type. + + -- type T is new I with private; + -- private + -- task type T is new I with ... + + if Is_Interface (Etype (Priv)) + and then Is_Concurrent_Type (Base_Type (Full)) + then + -- Protect the frontend against previous errors + + if Present (Corresponding_Record_Type + (Base_Type (Full))) + then + Set_Access_Disp_Table + (Priv, Access_Disp_Table + (Corresponding_Record_Type (Base_Type (Full)))); + else + pragma Assert (Serious_Errors_Detected > 0); + null; + end if; + + else + Set_Access_Disp_Table + (Priv, Access_Disp_Table (Base_Type (Full))); + end if; end if; Set_First_Entity (Priv, First_Entity (Full)); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 394f6dbb8e9..ee920be0869 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1101,6 +1101,7 @@ package body Sem_Ch8 is procedure Analyze_Subprogram_Renaming (N : Node_Id) is Spec : constant Node_Id := Specification (N); Save_AV : constant Ada_Version_Type := Ada_Version; + Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit; Nam : constant Node_Id := Name (N); New_S : Entity_Id; Old_S : Entity_Id := Empty; @@ -1357,9 +1358,24 @@ package body Sem_Ch8 is New_S := Rename_Spec; Set_Has_Completion (Rename_Spec, False); + -- Ada 2005: check overriding indicator. + + if Must_Override (Specification (N)) + and then not Is_Overriding_Operation (Rename_Spec) + then + Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); + + elsif Must_Not_Override (Specification (N)) + and then Is_Overriding_Operation (Rename_Spec) + then + Error_Msg_NE + ("subprogram& overrides inherited operation", N, Rename_Spec); + end if; + else Generate_Definition (New_S); New_Overloaded_Entity (New_S); + if Is_Entity_Name (Nam) and then Is_Intrinsic_Subprogram (Entity (Nam)) then @@ -1422,12 +1438,15 @@ package body Sem_Ch8 is Set_Has_Completion (New_S); end if; - -- Find the renamed entity that matches the given specification. - -- Disable Ada_83 because there is no requirement of full conformance - -- between renamed entity and new entity, even though the same circuit - -- is used. + -- Find the renamed entity that matches the given specification. Disable + -- Ada_83 because there is no requirement of full conformance between + -- renamed entity and new entity, even though the same circuit is used. + -- This is a bit of a kludge, which introduces a really irregular use of + -- Ada_Version[_Explicit]. Would be nice to find cleaner way to do this + -- ??? Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95); + Ada_Version_Explicit := Ada_Version; if No (Old_S) then Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); @@ -1444,11 +1463,10 @@ package body Sem_Ch8 is Generate_Reference (Old_S, Nam); end if; - -- For a renaming-as-body, require subtype conformance, - -- but if the declaration being completed has not been - -- frozen, then inherit the convention of the renamed - -- subprogram prior to checking conformance (unless the - -- renaming has an explicit convention established; the + -- For a renaming-as-body, require subtype conformance, but if the + -- declaration being completed has not been frozen, then inherit the + -- convention of the renamed subprogram prior to checking conformance + -- (unless the renaming has an explicit convention established; the -- rule stated in the RM doesn't seem to address this ???). if Present (Rename_Spec) then @@ -1516,15 +1534,15 @@ package body Sem_Ch8 is Set_Alias (New_S, Old_S); end if; - -- Note that we do not set Is_Intrinsic_Subprogram if we have - -- a renaming as body, since the entity in this case is not an - -- intrinsic (it calls an intrinsic, but we have a real body - -- for this call, and it is in this body that the required - -- intrinsic processing will take place). + -- Note that we do not set Is_Intrinsic_Subprogram if we have a + -- renaming as body, since the entity in this case is not an + -- intrinsic (it calls an intrinsic, but we have a real body for + -- this call, and it is in this body that the required intrinsic + -- processing will take place). - -- Also, if this is a renaming of inequality, the renamed - -- operator is intrinsic, but what matters is the corresponding - -- equality operator, which may be user-defined. + -- Also, if this is a renaming of inequality, the renamed operator + -- is intrinsic, but what matters is the corresponding equality + -- operator, which may be user-defined. Set_Is_Intrinsic_Subprogram (New_S, @@ -1594,9 +1612,9 @@ package body Sem_Ch8 is Set_Is_Abstract (New_S, Is_Abstract (Old_S)); Check_Library_Unit_Renaming (N, Old_S); - -- Pathological case: procedure renames entry in the scope of - -- its task. Entry is given by simple name, but body must be built - -- for procedure. Of course if called it will deadlock. + -- Pathological case: procedure renames entry in the scope of its + -- task. Entry is given by simple name, but body must be built for + -- procedure. Of course if called it will deadlock. if Ekind (Old_S) = E_Entry then Set_Has_Completion (New_S, False); @@ -1621,11 +1639,11 @@ package body Sem_Ch8 is end if; else - -- A common error is to assume that implicit operators for types - -- are defined in Standard, or in the scope of a subtype. In those - -- cases where the renamed entity is given with an expanded name, - -- it is worth mentioning that operators for the type are not - -- declared in the scope given by the prefix. + -- A common error is to assume that implicit operators for types are + -- defined in Standard, or in the scope of a subtype. In those cases + -- where the renamed entity is given with an expanded name, it is + -- worth mentioning that operators for the type are not declared in + -- the scope given by the prefix. if Nkind (Nam) = N_Expanded_Name and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol @@ -1675,7 +1693,40 @@ package body Sem_Ch8 is end if; end if; + -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that + -- controlling access parameters are known non-null for the renamed + -- subprogram. Test also applies to a subprogram instantiation that + -- is dispatching. + + if Ada_Version >= Ada_05 + and then not Is_Dispatching_Operation (Old_S) + and then Is_Dispatching_Operation (New_S) + then + declare + Old_F : Entity_Id; + New_F : Entity_Id; + + begin + Old_F := First_Formal (Old_S); + New_F := First_Formal (New_S); + while Present (Old_F) loop + if Ekind (Etype (Old_F)) = E_Anonymous_Access_Type + and then Is_Controlling_Formal (New_F) + and then not Can_Never_Be_Null (Old_F) + then + Error_Msg_N ("access parameter is controlling,", New_F); + Error_Msg_NE ("\corresponding parameter of& " & + " must be explicitly null excluding", New_F, Old_S); + end if; + + Next_Formal (Old_F); + Next_Formal (New_F); + end loop; + end; + end if; + Ada_Version := Save_AV; + Ada_Version_Explicit := Save_AV_Exp; end Analyze_Subprogram_Renaming; ------------------------- @@ -1699,9 +1750,9 @@ package body Sem_Ch8 is Set_Hidden_By_Use_Clause (N, No_Elist); -- Use clause is not allowed in a spec of a predefined package - -- declaration except that packages whose file name starts a-n - -- are OK (these are children of Ada.Numerics, and such packages - -- are never loaded by Rtsfind). + -- declaration except that packages whose file name starts a-n are OK + -- (these are children of Ada.Numerics, and such packages are never + -- loaded by Rtsfind). if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) and then Name_Buffer (1 .. 3) /= "a-n" @@ -1809,7 +1860,7 @@ package body Sem_Ch8 is if Nkind (Parent (N)) = N_Compilation_Unit then if Nkind (Id) = N_Identifier then - Error_Msg_N ("Type is not directly visible", Id); + Error_Msg_N ("type is not directly visible", Id); elsif Is_Child_Unit (Scope (Entity (Id))) and then Scope (Entity (Id)) /= System_Aux_Id @@ -2130,6 +2181,11 @@ package body Sem_Ch8 is and then Item /= N loop if Nkind (Item) = N_With_Clause + + -- Protect the frontend against previously reported + -- critical errors + + and then Nkind (Name (Item)) /= N_Selected_Component and then Entity (Name (Item)) = Pack then Par := Nam; @@ -3570,8 +3626,23 @@ package body Sem_Ch8 is if Present (Candidate) then if Is_Child_Unit (Candidate) then - Error_Msg_N - ("missing with_clause for child unit &", Selector); + + -- If the candidate is a private child unit and we are + -- in the visible part of a public unit, specialize the + -- error message. There might be a private with_clause for + -- it, but it is not currently active. + + if Is_Private_Descendant (Candidate) + and then Ekind (Current_Scope) = E_Package + and then not In_Private_Part (Current_Scope) + and then not Is_Private_Descendant (Current_Scope) + then + Error_Msg_N ("private child unit& is not visible here", + Selector); + else + Error_Msg_N + ("missing with_clause for child unit &", Selector); + end if; else Error_Msg_NE ("& is not a visible entity of&", N, Selector); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index fe354349b2c..ab963458c99 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2773,6 +2773,53 @@ package body Sem_Util is or else K = N_Package_Specification; end Has_Declarations; + ------------------------------------------- + -- Has_Discriminant_Dependent_Constraint -- + ------------------------------------------- + + function Has_Discriminant_Dependent_Constraint + (Comp : Entity_Id) return Boolean + is + Comp_Decl : constant Node_Id := Parent (Comp); + Subt_Indic : constant Node_Id := + Subtype_Indication (Component_Definition (Comp_Decl)); + Constr : Node_Id; + Assn : Node_Id; + + begin + if Nkind (Subt_Indic) = N_Subtype_Indication then + Constr := Constraint (Subt_Indic); + + if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then + Assn := First (Constraints (Constr)); + while Present (Assn) loop + case Nkind (Assn) is + when N_Subtype_Indication | + N_Range | + N_Identifier + => + if Depends_On_Discriminant (Assn) then + return True; + end if; + + when N_Discriminant_Association => + if Depends_On_Discriminant (Expression (Assn)) then + return True; + end if; + + when others => + null; + + end case; + + Next (Assn); + end loop; + end if; + end if; + + return False; + end Has_Discriminant_Dependent_Constraint; + -------------------- -- Has_Infinities -- -------------------- @@ -3403,58 +3450,9 @@ package body Sem_Util is P_Aliased : Boolean := False; Comp : Entity_Id; - function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean; - -- Returns True if and only if Comp has a constrained subtype - -- that depends on a discriminant. - function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; -- Returns True if and only if Comp is declared within a variant part - ------------------------------ - -- Has_Dependent_Constraint -- - ------------------------------ - - function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is - Comp_Decl : constant Node_Id := Parent (Comp); - Subt_Indic : constant Node_Id := - Subtype_Indication (Component_Definition (Comp_Decl)); - Constr : Node_Id; - Assn : Node_Id; - - begin - if Nkind (Subt_Indic) = N_Subtype_Indication then - Constr := Constraint (Subt_Indic); - - if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then - Assn := First (Constraints (Constr)); - while Present (Assn) loop - case Nkind (Assn) is - when N_Subtype_Indication | - N_Range | - N_Identifier - => - if Depends_On_Discriminant (Assn) then - return True; - end if; - - when N_Discriminant_Association => - if Depends_On_Discriminant (Expression (Assn)) then - return True; - end if; - - when others => - null; - - end case; - - Next (Assn); - end loop; - end if; - end if; - - return False; - end Has_Dependent_Constraint; - -------------------------------- -- Is_Declared_Within_Variant -- -------------------------------- @@ -3503,8 +3501,21 @@ package body Sem_Util is end if; + -- A heap object is constrained by its initial value + + -- Ada 2005 AI-363:if the designated type is a type with a + -- constrained partial view, the resulting heap object is not + -- constrained, and a renaming of the component is now unsafe. + if Is_Access_Type (Prefix_Type) - or else Nkind (P) = N_Explicit_Dereference + and then + not Has_Constrained_Partial_View + (Designated_Type (Prefix_Type)) + then + return False; + + elsif Nkind (P) = N_Explicit_Dereference + and then not Has_Constrained_Partial_View (Prefix_Type) then return False; end if; @@ -3523,7 +3534,7 @@ package body Sem_Util is and then In_Package_Body (Current_Scope))) and then (Is_Declared_Within_Variant (Comp) - or else Has_Dependent_Constraint (Comp)) + or else Has_Discriminant_Dependent_Constraint (Comp)) and then not P_Aliased then return True; @@ -4306,6 +4317,70 @@ package body Sem_Util is end if; end Is_Partially_Initialized_Type; + ------------------------------------ + -- Is_Potentially_Persistent_Type -- + ------------------------------------ + + function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is + Comp : Entity_Id; + Indx : Node_Id; + + begin + -- For private type, test corrresponding full type + + if Is_Private_Type (T) then + return Is_Potentially_Persistent_Type (Full_View (T)); + + -- Scalar types are potentially persistent + + elsif Is_Scalar_Type (T) then + return True; + + -- Record type is potentially persistent if not tagged and the types of + -- all it components are potentially persistent, and no component has + -- an initialization expression. + + elsif Is_Record_Type (T) + and then not Is_Tagged_Type (T) + and then not Is_Partially_Initialized_Type (T) + then + Comp := First_Component (T); + while Present (Comp) loop + if not Is_Potentially_Persistent_Type (Etype (Comp)) then + return False; + else + Next_Entity (Comp); + end if; + end loop; + + return True; + + -- Array type is potentially persistent if its component type is + -- potentially persistent and if all its constraints are static. + + elsif Is_Array_Type (T) then + if not Is_Potentially_Persistent_Type (Component_Type (T)) then + return False; + end if; + + Indx := First_Index (T); + while Present (Indx) loop + if not Is_OK_Static_Subtype (Etype (Indx)) then + return False; + else + Next_Index (Indx); + end if; + end loop; + + return True; + + -- All other types are not potentially persistent + + else + return False; + end if; + end Is_Potentially_Persistent_Type; + ----------------------------- -- Is_RCI_Pkg_Spec_Or_Body -- ----------------------------- @@ -6476,10 +6551,10 @@ package body Sem_Util is -- the level is the same as that of the enclosing component type. Btyp := Base_Type (Typ); + if Ekind (Btyp) in Access_Kind then if Ekind (Btyp) = E_Anonymous_Access_Type - and then not Is_Array_Type (Scope (Btyp)) -- Ada 2005 (AI-230) - and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 2005 (AI-230) + and then not Is_Local_Anonymous_Access (Typ) -- Ada 2005 (AI-230) then return Scope_Depth (Standard_Standard); end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 05df20c68d3..7b23a9c320e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -370,6 +370,11 @@ package Sem_Util is function Has_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations + function Has_Discriminant_Dependent_Constraint + (Comp : Entity_Id) return Boolean; + -- Returns True if and only if Comp has a constrained subtype + -- that depends on a discriminant. + function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes -- infinities. Returns False if E is not a floating-point type. @@ -534,6 +539,14 @@ package Sem_Util is -- one field has an initialization expression). Note that initialization -- resulting from the use of pragma Normalized_Scalars does not count. + function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean; + -- Determines if type T is a potentially persistent type. A potentially + -- persistent type is defined (recursively) as a scalar type, a non-tagged + -- record whose components are all of a potentially persistent type, or an + -- array with all static constraints whose component type is potentially + -- persistent. A private type is potentially persistent if the full type + -- is potentially persistent. + function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean; -- Return True if a compilation unit is the specification or the -- body of a remote call interface package. diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index c6117ee7b7c..d72a6e284a6 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1415,6 +1415,8 @@ package body Sinfo is or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Protected_Type_Declaration or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_Single_Protected_Declaration + or else NT (N).Nkind = N_Single_Task_Declaration or else NT (N).Nkind = N_Task_Type_Declaration); return List2 (N); end Interface_List; @@ -1745,6 +1747,30 @@ package body Sinfo is return Flag8 (N); end Must_Not_Freeze; + function Must_Not_Override + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + return Flag15 (N); + end Must_Not_Override; + + function Must_Override + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + return Flag14 (N); + end Must_Override; + function Name (N : Node_Id) return Node_Id is begin @@ -1872,6 +1898,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Component_List + or else NT (N).Nkind = N_Procedure_Specification or else NT (N).Nkind = N_Record_Definition); return Flag13 (N); end Null_Present; @@ -3939,6 +3966,8 @@ package body Sinfo is or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Protected_Type_Declaration or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_Single_Protected_Declaration + or else NT (N).Nkind = N_Single_Task_Declaration or else NT (N).Nkind = N_Task_Type_Declaration); Set_List2_With_Parent (N, Val); end Set_Interface_List; @@ -4269,6 +4298,30 @@ package body Sinfo is Set_Flag8 (N, Val); end Set_Must_Not_Freeze; + procedure Set_Must_Not_Override + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + Set_Flag15 (N, Val); + end Set_Must_Not_Override; + + procedure Set_Must_Override + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + Set_Flag14 (N, Val); + end Set_Must_Override; + procedure Set_Name (N : Node_Id; Val : Node_Id) is begin @@ -4396,6 +4449,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Component_List + or else NT (N).Nkind = N_Procedure_Specification or else NT (N).Nkind = N_Record_Definition); Set_Flag13 (N, Val); end Set_Null_Present; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c7df4dbd8d3..d5da73cb42c 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1958,6 +1958,8 @@ package Sinfo is -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ACCESS_DEFINITION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; -- | SINGLE_TASK_DECLARATION -- | SINGLE_PROTECTED_DECLARATION @@ -1994,13 +1996,17 @@ package Sinfo is -- extra temporary (with Is_True_Constant set False), and initialize -- this temporary as required (the temporary itself is not atomic). + -- Note: there is not node kind for object definition. Instead, the + -- corresponding field holds a subtype indication, an array type + -- definition, or (Ada 2005, AI-406) an access definition. + -- N_Object_Declaration -- Sloc points to first identifier -- Defining_Identifier (Node1) -- Aliased_Present (Flag4) set if ALIASED appears -- Constant_Present (Flag17) set if CONSTANT appears -- Null_Exclusion_Present (Flag11) - -- Object_Definition (Node4) subtype indication/array type definition + -- Object_Definition (Node4) subtype indic./array type def./ access def. -- Expression (Node3) (set to Empty if not present) -- Handler_List_Entry (Node2-Sem) -- Corresponding_Generic_Association (Node5-Sem) @@ -3893,8 +3899,10 @@ package Sinfo is ----------------------------------- -- SUBPROGRAM_SPECIFICATION ::= + -- [[not] overriding] -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE - -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE + -- | [[not] overriding] + -- function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE -- Note: there are no separate nodes for the profiles, instead the -- information appears directly in the following nodes. @@ -3906,6 +3914,8 @@ package Sinfo is -- Parameter_Specifications (List3) (set to No_List if no formal part) -- Subtype_Mark (Node4) for return type -- Generic_Parent (Node5-Sem) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present -- N_Procedure_Specification -- Sloc points to PROCEDURE @@ -3913,6 +3923,11 @@ package Sinfo is -- Elaboration_Boolean (Node2-Sem) -- Parameter_Specifications (List3) (set to No_List if no formal part) -- Generic_Parent (Node5-Sem) + -- Null_Present (Flag13) set for null procedure case (Ada 2005 feature) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present + + -- Note: overriding indicator is an Ada 2005 feature --------------------- -- 6.1 Designator -- @@ -4470,11 +4485,13 @@ package Sinfo is ---------------------------------- -- SINGLE_TASK_DECLARATION ::= - -- task DEFINING_IDENTIFIER [is TASK_DEFINITION]; + -- task DEFINING_IDENTIFIER + -- [is [new INTERFACE_LIST with] TASK_DEFINITITION]; -- N_Single_Task_Declaration -- Sloc points to TASK -- Defining_Identifier (Node1) + -- Interface_List (List2) (set to No_List if none) -- Task_Definition (Node3) (set to Empty if not present) -------------------------- @@ -4553,13 +4570,15 @@ package Sinfo is --------------------------------------- -- SINGLE_PROTECTED_DECLARATION ::= - -- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION; + -- protected DEFINING_IDENTIFIER + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; -- Note: single protected declarations are not allowed in Ada 83 mode -- N_Single_Protected_Declaration -- Sloc points to PROTECTED -- Defining_Identifier (Node1) + -- Interface_List (List2) (set to No_List if none) -- Protected_Definition (Node3) ------------------------------- @@ -4631,6 +4650,7 @@ package Sinfo is ------------------------------ -- ENTRY_DECLARATION ::= + -- [[not] overriding] -- entry DEFINING_IDENTIFIER -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE; @@ -4640,6 +4660,10 @@ package Sinfo is -- Discrete_Subtype_Definition (Node4) (set to Empty if not present) -- Parameter_Specifications (List3) (set to No_List if no formal part) -- Corresponding_Body (Node5-Sem) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present + + -- Note: overriding indicator is an Ada 2005 feature ----------------------------- -- 9.5.2 Accept statement -- @@ -5489,9 +5513,11 @@ package Sinfo is -- GENERIC_INSTANTIATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is -- new generic_package_NAME [GENERIC_ACTUAL_PART]; - -- | procedure DEFINING_PROGRAM_UNIT_NAME is + -- | [[not] overriding] + -- procedure DEFINING_PROGRAM_UNIT_NAME is -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; - -- | function DEFINING_DESIGNATOR is + -- | [[not] overriding] + -- function DEFINING_DESIGNATOR is -- new generic_function_NAME [GENERIC_ACTUAL_PART]; -- N_Package_Instantiation @@ -5512,6 +5538,8 @@ package Sinfo is -- Generic_Associations (List3) (set to No_List if no -- generic actual part) -- Instance_Spec (Node5-Sem) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present -- ABE_Is_Certain (Flag18-Sem) -- N_Function_Instantiation @@ -5522,8 +5550,12 @@ package Sinfo is -- generic actual part) -- Parent_Spec (Node4-Sem) -- Instance_Spec (Node5-Sem) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present -- ABE_Is_Certain (Flag18-Sem) + -- Note: overriding indicator is an Ada 2005 feature + ------------------------------ -- 12.3 Generic Actual Part -- ------------------------------ @@ -7565,6 +7597,12 @@ package Sinfo is function Must_Not_Freeze (N : Node_Id) return Boolean; -- Flag8 + function Must_Not_Override + (N : Node_Id) return Boolean; -- Flag15 + + function Must_Override + (N : Node_Id) return Boolean; -- Flag14 + function Name (N : Node_Id) return Node_Id; -- Node2 @@ -8366,6 +8404,12 @@ package Sinfo is procedure Set_Must_Not_Freeze (N : Node_Id; Val : Boolean := True); -- Flag8 + procedure Set_Must_Not_Override + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Must_Override + (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Name (N : Node_Id; Val : Node_Id); -- Node2 @@ -8828,6 +8872,8 @@ package Sinfo is pragma Inline (More_Ids); pragma Inline (Must_Be_Byte_Aligned); pragma Inline (Must_Not_Freeze); + pragma Inline (Must_Not_Override); + pragma Inline (Must_Override); pragma Inline (Name); pragma Inline (Names); pragma Inline (Next_Entity); @@ -9092,6 +9138,8 @@ package Sinfo is pragma Inline (Set_More_Ids); pragma Inline (Set_Must_Be_Byte_Aligned); pragma Inline (Set_Must_Not_Freeze); + pragma Inline (Set_Must_Not_Override); + pragma Inline (Set_Must_Override); pragma Inline (Set_Name); pragma Inline (Set_Names); pragma Inline (Set_Next_Entity); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 24998600727..4e875fa52a4 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -165,6 +165,9 @@ package body Sprint is -- that is currently being written. Note that Debug_Node is always empty -- if a debug source file is not being written. + procedure Sprint_And_List (List : List_Id); + -- Print the given list with items separated by vertical "and" + procedure Sprint_Bar_List (List : List_Id); -- Print the given list with items separated by vertical bars @@ -480,16 +483,32 @@ package body Sprint is end Source_Dump; --------------------- + -- Sprint_And_List -- + --------------------- + + procedure Sprint_And_List (List : List_Id) is + Node : Node_Id; + begin + if Is_Non_Empty_List (List) then + Node := First (List); + loop + Sprint_Node (Node); + Next (Node); + exit when Node = Empty; + Write_Str (" and "); + end loop; + end if; + end Sprint_And_List; + + --------------------- -- Sprint_Bar_List -- --------------------- procedure Sprint_Bar_List (List : List_Id) is Node : Node_Id; - begin if Is_Non_Empty_List (List) then Node := First (List); - loop Sprint_Node (Node); Next (Node); @@ -509,7 +528,6 @@ package body Sprint is begin if Is_Non_Empty_List (List) then Node := First (List); - loop Sprint_Node (Node); Next (Node); @@ -520,7 +538,6 @@ package body Sprint is then Write_Str (", "); end if; - end loop; end if; end Sprint_Comma_List; @@ -1146,8 +1163,16 @@ package body Sprint is Sprint_Node (Subtype_Indication (Node)); - if Present (Record_Extension_Part (Node)) then + if Present (Interface_List (Node)) then + Sprint_And_List (Interface_List (Node)); Write_Str_With_Col_Check (" with "); + end if; + + if Present (Record_Extension_Part (Node)) then + if No (Interface_List (Node)) then + Write_Str_With_Col_Check (" with "); + end if; + Sprint_Node (Record_Extension_Part (Node)); end if; @@ -2149,7 +2174,15 @@ package body Sprint is Write_Indent_Str_Sloc ("protected type "); Write_Id (Defining_Identifier (Node)); Write_Discr_Specs (Node); - Write_Str (" is"); + + if Present (Interface_List (Node)) then + Write_Str (" is new "); + Sprint_And_List (Interface_List (Node)); + Write_Str (" with "); + else + Write_Str (" is"); + end if; + Sprint_Node (Protected_Definition (Node)); Write_Id (Defining_Identifier (Node)); Write_Char (';'); @@ -2400,6 +2433,13 @@ package body Sprint is when N_Subprogram_Declaration => Write_Indent; Sprint_Node_Sloc (Specification (Node)); + + if Nkind (Specification (Node)) = N_Procedure_Specification + and then Null_Present (Specification (Node)) + then + Write_Str_With_Col_Check (" is null"); + end if; + Write_Char (';'); when N_Subprogram_Info => @@ -2471,8 +2511,18 @@ package body Sprint is Write_Id (Defining_Identifier (Node)); Write_Discr_Specs (Node); + if Present (Interface_List (Node)) then + Write_Str (" is new "); + Sprint_And_List (Interface_List (Node)); + end if; + if Present (Task_Definition (Node)) then - Write_Str (" is"); + if No (Interface_List (Node)) then + Write_Str (" is"); + else + Write_Str (" with "); + end if; + Sprint_Node (Task_Definition (Node)); Write_Id (Defining_Identifier (Node)); end if; |