diff options
Diffstat (limited to 'gcc/ada')
41 files changed, 838 insertions, 574 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f45c81a..3af5b5d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,259 @@ +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Constrain_Index): In the case of a fixed-lower-bound index, + set Etype of the newly created itype's Scalar_Range from the index's Etype. + * sem_ch12.adb (Validate_Array_Type_Instance): If the actual subtype is + a fixed-lower-bound type, then check again the Etype of its Scalar_Range. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Fix conditions for legality checks on + formal type declarations. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): If pragmas apply to a formal array + type, then set the flags on the base type. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Subtype): Clarify code. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.ads (Process_Subtype): Add formal. + * sem_ch3.adb (Process_Subtype): Use new formal. + (Analyze_Subtype_Declaration, Array_Type_Declaration, + Build_Derived_Access_Type): Pass new actual. + * sem_ch4.adb (Find_Type_Of_Object): Likewise. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch6.adb (Set_Formal_Mode): Extend profile. Move parts of the + body… + (Process_Formals): … here. Move call to Set_Formal_Mode earlier. Call + Set_Is_Not_Self_Hidden in second traversal. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Expand_Container_Aggregate): Use the Base_Type of the + subtype provided by the context as the subtype of the temporary object + initialized by the aggregate. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * par-ch4.adb (P_Function_Name): Delete body. + (P_Qualified_Simple_Name_Resync): Do not raise Error_Resync on an + operator symbol followed by something else than a dot. + * par-ch6.adb (P_Subprogram): Do not call P_Function_Name. + * par.adb (P_Function_Name): Delete declaration. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem.adb (Analyze): Adapt to new Ekinds. + * sem_ch3.adb (Analyze_Component_Declaration): Set Ekind early. + (Is_Visible_Component, Record_Type_Definition): Adjust. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem.adb (Analyze): Fix comment. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * par-ch4.adb (P_Name): Remove obsolete references in comments. + (P_Qualified_Simple_Name): Call P_Qualified_Simple_Name_Resync. + (P_Qualified_Simple_Name_Resync): Adjust a couple of comments. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * exp_util.adb (Call_To_Parent_Dispatching_Op_Must_Be_Mapped): Replace + test of Covers with test of Is_Controlling_Formal. Add handling for + 'Result actuals. Remove Actual_Type and its uses. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_Name_Reference): Remove check for selector_name of a + selected_component; reuse existing code for indexed components and + slices. + (Statically_Names_Object): Remove dead code. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Overlays_Constant): Define in constants and variables. + * gen_il-gen-gen_entities.adb (Entity_Kind): Move Overlays_Constant + semantic flag to... + (Constant_Or_Variable_Kind): ...here. + * sem_util.adb (Note_Possible_Modification): Add guard. + +2025-06-09 Bob Duff <duff@adacore.com> + + * exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): + Deal with renamings transformed into object declarations. + * sem_ch8.adb (Analyze_Object_Renaming): + Reinstate transformation of a renaming into + an object declaration. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Call Mutate_Ekind earlier. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Tweak error handling. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * par-ch13.adb (Get_Aspect_Specifications): Save and restore flag while + parsing aspect Abstract_State. + * par-ch2.adb (P_Pragma): Same while parsing pragma Abstract_State. + * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Specialize error message + for contract Abstract_State and extended aggregate. + * par.adb (Inside_Abstract_State): Add new context flag. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch10.adb (Analyze_Compilation_Unit): Check for generic bodies. + * exp_disp.adb (Build_Dispatch_Tables): Likewise. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Find_Overlaid_Entity): Don't call Etype on empty Ent; + tune style; move computation of Overl_Typ out of the loop. + +2025-06-09 Javier Miranda <miranda@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Adding + documentation. + * doc/gnat_ugn/the_gnat_compilation_model.rst: ditto. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_attr.adb (Analyze_Attribute): Remove test. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_util.adb (Enter_Name): Remove special handling. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_util.adb (Enter_Name): Remove comment. + +2025-06-09 Bob Duff <duff@adacore.com> + + * exp_ch6.adb: Remove a couple of "???" suggesting something that + we will likely never do. + (Make_Build_In_Place_Call_In_Object_Declaration): + When a constraint check is needed, do the check. + Do it at the call site for now. + The check is still missing in the untagged case, + because the caller allocates in that case. + * sem_ch8.adb (Analyze_Object_Renaming): + Remove obsolete transformation of a renaming into + an object declaration. Given that we also (sometimes) tranform + object declarations into renamings, this transformation was + adding complexity; the new code in + Make_Build_In_Place_Call_In_Object_Declaration above + would need to explicitly avoid the run-time check in the case of + renamings, because renamings are supposed to ignore the nominal + subtype. Anyway, it is no longer needed. + * exp_ch3.adb (Expand_N_Object_Declaration): Rewrite comment; + it IS clear how to do it, but we haven't done it right yet. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * atree.ads (Copy_Node): Fix comment. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): When expanding attribute + Valid, use signedness from the validated view, not from its base type. + +2025-06-09 Marc Poulhiès <poulhies@adacore.com> + + * sem_util.adb (Find_Overlaid_Entity): Add extra parameter to + extract the type being overlaid. + (Note_Possible_Modification): Adjust call to Find_Overlaid_Entity. + (Ultimate_Overlaid_Entity): Likewise. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Likewise. + * sem_util.ads (Find_Overlaid_Entity): Add extra parameter to + extract the type being overlaid. + * freeze.adb (Check_Address_Clause): Likewise. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * contracts.adb (Inherit_Condition): Remove Assoc_List and its uses + along with function Check_Condition, since mapping of formals will + effectively be done in Build_Class_Wide_Expression (by Replace_Entity). + * exp_util.adb (Replace_Entity): Only rewrite entity references in + function calls that qualify according to the result of calling the + new function Call_To_Parent_Dispatching_Op_Must_Be_Mapped. + (Call_To_Parent_Dispatching_Op_Must_Be_Mapped): New function that + determines whether a function call to a primitive of Par_Subp + associated tagged type needs to be mapped (according to whether + it has any actuals that reference controlling formals of the + primitive). + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Remove comment. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_util.ads (Current_Entity_In_Scope): Add example in comment. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * atree.ads (Rewrite, Replace): Clarify comments. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * atree.ads (Rewrite): Remove comment. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * atree.adb (Rewrite): Improve readability. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_util.adb (Kill_Current_Values): Tweak condition. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Insert_Conditional_Object_Declaration): Remove Decl + formal parameter, add Typ and Const formal parameters. + (Expand_N_Case_Expression): Fix pasto in comment. Adjust call to + Insert_Conditional_Object_Declaration and tidy up surrounding code. + (Expand_N_If_Expression): Adjust couple of calls to + Insert_Conditional_Object_Declaration. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch8.adb (Find_Selected_Component): Fix error path. + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-dourea.adb (Is_Infinity): Rename to... + (Is_Infinity_Or_NaN): ...this. + ("*"): Adjust accordingly. + ("/"): Likewise. + (Sqr): Likewise. + * libgnat/s-dorepr.adb (Two_Prod): Likewise. + (Two_Sqr): Likewise. + * libgnat/s-dorepr__fma.adb (Two_Prod): Likewise. + +2025-06-09 Daniel King <dmking@adacore.com> + + * libgnat/i-cheri.ads + (Set_Bounds, Set_Exact_Bounds): Remove wrong intrinsic binding. + * libgnat/i-cheri.adb + (Set_Bounds, Set_Exact_Bounds): New subprogram bodies. + +2025-06-09 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch8.adb (Find_Selected_Component): Add mention. + 2025-06-06 Piotr Trojanek <trojanek@adacore.com> * urealp.adb (UR_Negate): Capture array element in a local constant. diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 8a69a0c..3fa55a7 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -2271,10 +2271,10 @@ package body Atree is -- Copy substitute node into place, preserving old fields as required Copy_Node (Source => New_Node, Destination => Old_Node); - Set_Error_Posted (Old_Node, Old_Error_Posted); Set_Check_Actuals (Old_Node, Old_CA); Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN); + Set_Error_Posted (Old_Node, Old_Error_Posted); if Nkind (New_Node) in N_Subexpr then Set_Paren_Count (Old_Node, Old_Paren_Count); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index c8cc2bc..615d040 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -285,15 +285,11 @@ package Atree is procedure Copy_Node (Source, Destination : Node_Or_Entity_Id); -- Copy the entire contents of the source node to the destination node. - -- The contents of the source node is not affected. If the source node - -- has an extension, then the destination must have an extension also. - -- The parent pointer of the destination and its list link, if any, are - -- not affected by the copy. Note that parent pointers of descendants - -- are not adjusted, so the descendants of the destination node after - -- the Copy_Node is completed have dubious parent pointers. Note that - -- this routine does NOT copy aspect specifications, the Has_Aspects - -- flag in the returned node will always be False. The caller must deal - -- with copying aspect specifications where this is required. + -- The contents of the source node is not affected. The parent pointer of + -- the destination and its list link, if any, are not affected by the copy. + -- Note that parent pointers of descendants are not adjusted, so the + -- descendants of the destination node after the Copy_Node is completed + -- have dubious parent pointers. function New_Copy (Source : Node_Id) return Node_Id; -- This function allocates a new node, and then initializes it by copying @@ -536,16 +532,13 @@ package Atree is procedure Rewrite (Old_Node, New_Node : Node_Id); -- This is used when a complete subtree is to be replaced. Old_Node is the -- root of the old subtree to be replaced, and New_Node is the root of the - -- newly constructed replacement subtree. The actual mechanism is to swap - -- the contents of these two nodes fixing up the parent pointers of the - -- replaced node (we do not attempt to preserve parent pointers for the - -- original node). - -- ??? The above explanation is incorrect, instead Copy_Node is called. + -- newly constructed replacement subtree. -- -- Note: New_Node may not contain references to Old_Node, for example as - -- descendants, since the rewrite would make such references invalid. If - -- New_Node does need to reference Old_Node, then these references should - -- be to a relocated copy of Old_Node (see Relocate_Node procedure). + -- descendants, since the rewrite would turn them into cyclic + -- self-references. If New_Node does need to reference Old_Node, then these + -- references should be to a relocated copy of Old_Node (see Relocate_Node + -- procedure). -- -- Note: The Original_Node function applied to Old_Node (which has now -- been replaced by the contents of New_Node), can be used to obtain the @@ -559,10 +552,8 @@ package Atree is -- original contents of the Old_Node, but rather the New_Node value. -- Replace also preserves the setting of Comes_From_Source. -- - -- Note that New_Node must not contain references to Old_Node, for example - -- as descendants, since the rewrite would make such references invalid. If - -- New_Node does need to reference Old_Node, then these references should - -- be to a relocated copy of Old_Node (see Relocate_Node procedure). + -- The note in the documentation of Rewrite about the risk of creating + -- cyclic references also applies here. -- -- Replace is used in certain circumstances where it is desirable to -- suppress any history of the rewriting operation. Notably, it is used diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 810458a..70e9487 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4399,10 +4399,10 @@ package body Contracts is Seen : Subprogram_List (Subps'Range) := (others => Empty); function Inherit_Condition - (Par_Subp : Entity_Id; - Subp : Entity_Id) return Node_Id; - -- Inherit the class-wide condition from Par_Subp to Subp and adjust - -- all the references to formals in the inherited condition. + (Par_Subp : Entity_Id) return Node_Id; + -- Inherit the class-wide condition from Par_Subp. Simply makes + -- a copy of the condition in preparation for later mapping of + -- referenced formals and functions by Build_Class_Wide_Expression. procedure Merge_Conditions (From : Node_Id; Into : Node_Id); -- Merge two class-wide preconditions or postconditions (the former @@ -4417,92 +4417,11 @@ package body Contracts is ----------------------- function Inherit_Condition - (Par_Subp : Entity_Id; - Subp : Entity_Id) return Node_Id - is - function Check_Condition (Expr : Node_Id) return Boolean; - -- Used in assertion to check that Expr has no reference to the - -- formals of Par_Subp. - - --------------------- - -- Check_Condition -- - --------------------- - - function Check_Condition (Expr : Node_Id) return Boolean is - Par_Formal_Id : Entity_Id; - - function Check_Entity (N : Node_Id) return Traverse_Result; - -- Check occurrence of Par_Formal_Id - - ------------------ - -- Check_Entity -- - ------------------ - - function Check_Entity (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Identifier - and then Present (Entity (N)) - and then Entity (N) = Par_Formal_Id - then - return Abandon; - end if; - - return OK; - end Check_Entity; - - function Check_Expression is new Traverse_Func (Check_Entity); - - -- Start of processing for Check_Condition - - begin - Par_Formal_Id := First_Formal (Par_Subp); - - while Present (Par_Formal_Id) loop - if Check_Expression (Expr) = Abandon then - return False; - end if; - - Next_Formal (Par_Formal_Id); - end loop; - - return True; - end Check_Condition; - - -- Local variables - - Assoc_List : constant Elist_Id := New_Elmt_List; - Par_Formal_Id : Entity_Id := First_Formal (Par_Subp); - Subp_Formal_Id : Entity_Id := First_Formal (Subp); - New_Condition : Node_Id; - + (Par_Subp : Entity_Id) return Node_Id is begin - while Present (Par_Formal_Id) loop - Append_Elmt (Par_Formal_Id, Assoc_List); - Append_Elmt (Subp_Formal_Id, Assoc_List); - - Next_Formal (Par_Formal_Id); - Next_Formal (Subp_Formal_Id); - end loop; - - -- Check that Parent field of all the nodes have their correct - -- decoration; required because otherwise mapped nodes with - -- wrong Parent field are left unmodified in the copied tree - -- and cause reporting wrong errors at later stages. - - pragma Assert - (Check_Parents (Class_Condition (Kind, Par_Subp), Assoc_List)); - - New_Condition := + return New_Copy_Tree - (Source => Class_Condition (Kind, Par_Subp), - Map => Assoc_List); - - -- Ensure that the inherited condition has no reference to the - -- formals of the parent subprogram. - - pragma Assert (Check_Condition (New_Condition)); - - return New_Condition; + (Source => Class_Condition (Kind, Par_Subp)); end Inherit_Condition; ---------------------- @@ -4616,9 +4535,7 @@ package body Contracts is Par_Prim := Subp_Id; Par_Iface_Prims := Covered_Interface_Primitives (Par_Prim); - Cond := Inherit_Condition - (Subp => Spec_Id, - Par_Subp => Subp_Id); + Cond := Inherit_Condition (Par_Subp => Subp_Id); if Present (Class_Cond) then Merge_Conditions (Cond, Class_Cond); @@ -4662,9 +4579,7 @@ package body Contracts is then Seen (Index) := Subp_Id; - Cond := Inherit_Condition - (Subp => Spec_Id, - Par_Subp => Subp_Id); + Cond := Inherit_Condition (Par_Subp => Subp_Id); Check_Class_Condition (Cond => Cond, diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index cae8c16..02013f1 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -123,6 +123,11 @@ and generics may name types with unknown discriminants without using the ``(<>)`` notation. In addition, some but not all of the additional restrictions of Ada 83 are enforced. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + Ada 83 mode is intended for two purposes. Firstly, it allows existing Ada 83 code to be compiled and adapted to GNAT with less effort. Secondly, it aids in keeping code backwards compatible with Ada 83. @@ -149,6 +154,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 95 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + Pragma Ada_05 ============= @@ -166,6 +176,11 @@ This pragma is useful when writing a reusable component that itself uses Ada 2005 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form (which is not a configuration pragma) is used for managing the transition from Ada 95 to Ada 2005 in the run-time library. If an entity is marked @@ -209,6 +224,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 2012 features, but which is intended to be usable from Ada 83, Ada 95, or Ada 2005 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form, which is not a configuration pragma, is used for managing the transition from Ada 2005 to Ada 2012 in the run-time library. If an entity is marked @@ -252,6 +272,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 2022 features, but which is intended to be usable from Ada 83, Ada 95, Ada 2005 or Ada 2012 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form, which is not a configuration pragma, is used for managing the transition from Ada 2012 to Ada 2022 in the run-time library. If an entity is marked diff --git a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst index 64a3631..891886b 100644 --- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst +++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst @@ -1477,6 +1477,10 @@ You can place configuration pragmas either appear at the start of a compilation unit or in a configuration pragma file that applies to all compilations performed in a given compilation environment. +Configuration pragmas placed before a library level package specification +are not propagated to the corresponding package body (see RM 10.1.5(8)); +they must be added explicitly to the package body. + GNAT includes the ``gnatchop`` utility to provide an automatic way to handle configuration pragmas that follows the semantics for compilations (that is, files with multiple units) described in the RM. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 545c15d..1cbac6d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3927,9 +3927,8 @@ package Einfo is -- Points to the component in the base type. -- Overlays_Constant --- Defined in all entities. Set only for E_Constant or E_Variable for --- which there is an address clause that causes the entity to overlay --- a constant object. +-- Defined in constants and variables. Set if there is an address clause +-- that causes the entity to overlay a constant object. -- Overridden_Operation -- Defined in subprograms. For overriding operations, points to the @@ -4961,7 +4960,6 @@ package Einfo is -- Materialize_Entity -- Needs_Debug_Info -- Never_Set_In_Source - -- Overlays_Constant -- Referenced -- Referenced_As_LHS -- Referenced_As_Out_Parameter @@ -5288,7 +5286,7 @@ package Einfo is -- Interface_Name (constants only) -- Related_Type (constants only) -- Initialization_Statements - -- BIP_Initialization_Call + -- BIP_Initialization_Call (constants only) -- Finalization_Master_Node -- Last_Aggregate_Assignment -- Activation_Record_Component @@ -5318,6 +5316,7 @@ package Einfo is -- Is_Volatile_Full_Access -- Optimize_Alignment_Space (constants only) -- Optimize_Alignment_Time (constants only) + -- Overlays_Constant (constants only) -- SPARK_Pragma_Inherited (constants only) -- Stores_Attribute_Old_Prefix (constants only) -- Treat_As_Volatile @@ -6205,6 +6204,7 @@ package Einfo is -- OK_To_Rename -- Optimize_Alignment_Space -- Optimize_Alignment_Time + -- Overlays_Constant -- SPARK_Pragma_Inherited -- Suppress_Initialization -- Treat_As_Volatile diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 5450402..8db15fa 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -7503,10 +7503,19 @@ package body Exp_Aggr is Set_Assignment_OK (Lhs); Aggr_Code := Build_Container_Aggr_Code (N, Typ, Lhs, Init); + + -- Use the unconstrained base subtype of the subtype provided by + -- the context for declaring the temporary object (which may come + -- from a constrained assignment target), to ensure that the + -- aggregate can be successfully expanded and assigned to the + -- temporary without exceeding its capacity. (Later assignment + -- of the temporary to a target object may result in failing + -- a discriminant check.) + Prepend_To (Aggr_Code, Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, - Object_Definition => New_Occurrence_Of (Typ, Loc), + Object_Definition => New_Occurrence_Of (Base_Type (Typ), Loc), Expression => Init)); Insert_Actions (N, Aggr_Code); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index f1f8424..3d1bff9 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -8183,9 +8183,8 @@ package body Exp_Attr is else declare Uns : constant Boolean := - Is_Unsigned_Type (Ptyp) - or else (Is_Private_Type (Ptyp) - and then Is_Unsigned_Type (PBtyp)); + Is_Unsigned_Type (Validated_View (Ptyp)); + Size : Uint; P : Node_Id := Pref; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d884e75..cf2238e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8741,8 +8741,9 @@ package body Exp_Ch3 is -- be illegal in some cases (such as converting access- -- to-unconstrained to access-to-constrained), but the -- the unchecked conversion will presumably fail to work - -- right in just such cases. It's not clear at all how to - -- handle this. + -- right in just such cases. In order to handle this + -- properly, in the Caller_Allocation case, the callee + -- needs to do the constraint check. Alloc_Stmt := Make_If_Statement (Loc, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 01be3df..1c2a876 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -193,12 +193,12 @@ package body Exp_Ch4 is procedure Insert_Conditional_Object_Declaration (Obj_Id : Entity_Id; + Typ : Entity_Id; Expr : Node_Id; - Decl : Node_Id); - -- Expr is the dependent expression of a conditional expression and Decl - -- is the declaration of an object whose initialization expression is the - -- conditional expression. Insert in the actions of Expr the declaration - -- of Obj_Id modeled on Decl and with Expr as initialization expression. + Const : Boolean); + -- Expr is the dependent expression of a conditional expression. Insert in + -- the actions of Expr the declaration of Obj_Id with type Typ and Expr as + -- initialization expression. Const is True when Obj_Id is a constant. procedure Insert_Dereference_Action (N : Node_Id); -- N is an expression whose type is an access. When the type of the @@ -5313,7 +5313,7 @@ package body Exp_Ch4 is -- 'Unrestricted_Access. -- Generate: - -- type Ptr_Typ is not null access all [constant] Typ; + -- type Target_Typ is not null access all [constant] Typ; else Target_Typ := Make_Temporary (Loc, 'P'); @@ -5411,20 +5411,16 @@ package body Exp_Ch4 is elsif Optimize_Object_Decl then Obj := Make_Temporary (Loc, 'C', Alt_Expr); - Insert_Conditional_Object_Declaration (Obj, Alt_Expr, Par); - - Alt_Expr := - Make_Attribute_Reference (Alt_Loc, - Prefix => New_Occurrence_Of (Obj, Alt_Loc), - Attribute_Name => Name_Unrestricted_Access); - - LHS := New_Occurrence_Of (Target, Loc); - Set_Assignment_OK (LHS); + Insert_Conditional_Object_Declaration + (Obj, Typ, Alt_Expr, Const => Constant_Present (Par)); Stmts := New_List ( Make_Assignment_Statement (Alt_Loc, - Name => LHS, - Expression => Alt_Expr)); + Name => New_Occurrence_Of (Target, Loc), + Expression => + Make_Attribute_Reference (Alt_Loc, + Prefix => New_Occurrence_Of (Obj, Alt_Loc), + Attribute_Name => Name_Unrestricted_Access))); -- Take the unrestricted access of the expression value for non- -- scalar types. This approach avoids big copies and covers the @@ -6022,8 +6018,10 @@ package body Exp_Ch4 is Target : constant Entity_Id := Make_Temporary (Loc, 'C', N); begin - Insert_Conditional_Object_Declaration (Then_Obj, Thenx, Par); - Insert_Conditional_Object_Declaration (Else_Obj, Elsex, Par); + Insert_Conditional_Object_Declaration + (Then_Obj, Typ, Thenx, Const => Constant_Present (Par)); + Insert_Conditional_Object_Declaration + (Else_Obj, Typ, Elsex, Const => Constant_Present (Par)); -- Generate: -- type Ptr_Typ is not null access all [constant] Typ; @@ -13294,16 +13292,17 @@ package body Exp_Ch4 is procedure Insert_Conditional_Object_Declaration (Obj_Id : Entity_Id; + Typ : Entity_Id; Expr : Node_Id; - Decl : Node_Id) + Const : Boolean) is Loc : constant Source_Ptr := Sloc (Expr); Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, Aliased_Present => True, - Constant_Present => Constant_Present (Decl), - Object_Definition => New_Copy_Tree (Object_Definition (Decl)), + Constant_Present => Const, + Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Expr)); -- We make the object unconditionally aliased to avoid dangling bound -- issues when its nominal subtype is an unconstrained array type. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f85d977..3a45b1c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -158,7 +158,7 @@ package body Exp_Ch6 is Alloc_Form_Exp : Node_Id := Empty; Pool_Exp : Node_Id := Empty); -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs - -- them, add the actuals parameters BIP_Alloc_Form and BIP_Storage_Pool. + -- them, add the actual parameters BIP_Alloc_Form and BIP_Storage_Pool. -- If Alloc_Form_Exp is present, then pass it for the first parameter, -- otherwise pass a literal corresponding to the Alloc_Form parameter -- (which must not be Unspecified in that case). If Pool_Exp is present, @@ -442,9 +442,7 @@ package body Exp_Ch6 is return; end if; - -- Locate the implicit allocation form parameter in the called function. - -- Maybe it would be better for each implicit formal of a build-in-place - -- function to have a flag or a Uint attribute to identify it. ??? + -- Locate the implicit allocation form parameter in the called function Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); @@ -928,9 +926,6 @@ package body Exp_Ch6 is Formal_Suffix : constant String := BIP_Formal_Suffix (Kind); begin - -- Maybe it would be better for each implicit formal of a build-in-place - -- function to have a flag or a Uint attribute to identify it. ??? - -- The return type in the function declaration may have been a limited -- view, and the extra formals for the function were not generated at -- that point. At the point of call the full view must be available and @@ -8821,6 +8816,25 @@ package body Exp_Ch6 is and then not Has_Foreign_Convention (Return_Applies_To (Scope (Obj_Def_Id))); + Constraint_Check_Needed : constant Boolean := + (Has_Discriminants (Obj_Typ) or else Is_Array_Type (Obj_Typ)) + and then Is_Tagged_Type (Obj_Typ) + and then Nkind (Original_Node (Obj_Decl)) /= + N_Object_Renaming_Declaration + and then Is_Constrained (Obj_Typ); + -- We are processing a call in the context of something like + -- "X : T := F (...);". This is True if we need to do a constraint + -- check, because T has constrained bounds or discriminants, + -- and F is returning an unconstrained subtype. + -- We are currently doing the check at the call site, + -- which is possible only in the callee-allocates case, + -- which is why we have Is_Tagged_Type above. + -- ???The check is missing in the untagged caller-allocates case. + -- ???The check for renaming declarations above is needed because + -- Sem_Ch8.Analyze_Object_Renaming sometimes changes a renaming + -- into an object declaration. We probably shouldn't do that, + -- but for now, we need this check. + -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration begin @@ -8863,15 +8877,16 @@ package body Exp_Ch6 is Subtype_Indication => New_Occurrence_Of (Designated_Type, Loc))); - -- The access type and its accompanying object must be inserted after - -- the object declaration in the constrained case, so that the function - -- call can be passed access to the object. In the indefinite case, or + -- The access type and its object must be inserted after the object + -- declaration in the caller-allocates case, so that the function call + -- can be passed access to the object. In the caller-allocates case, or -- if the object declaration is for a return object, the access type and -- object must be inserted before the object, since the object -- declaration is rewritten to be a renaming of a dereference of the -- access object. - if Definite and then not Is_OK_Return_Object then + if Definite and not Is_OK_Return_Object and not Constraint_Check_Needed + then Insert_Action_After (Obj_Decl, Ptr_Typ_Decl); else Insert_Action (Obj_Decl, Ptr_Typ_Decl); @@ -8952,7 +8967,7 @@ package body Exp_Ch6 is -- to the (specific) result type of the function is inserted to handle -- the case where the object is declared with a class-wide type. - elsif Definite then + elsif Definite and not Constraint_Check_Needed then Caller_Object := Unchecked_Convert_To (Result_Subt, New_Occurrence_Of (Obj_Def_Id, Loc)); @@ -9090,8 +9105,8 @@ package body Exp_Ch6 is -- itself the return expression of an enclosing BIP function, then mark -- the object as having no initialization. - if Definite and then not Is_OK_Return_Object then - + if Definite and not Is_OK_Return_Object and not Constraint_Check_Needed + then Set_Expression (Obj_Decl, Empty); Set_No_Initialization (Obj_Decl); @@ -9150,6 +9165,10 @@ package body Exp_Ch6 is Analyze (Obj_Decl); Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl)); + + if Constraint_Check_Needed then + Apply_Constraint_Check (Call_Deref, Obj_Typ); + end if; end if; pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 458b32c..080a2e1 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -413,7 +413,9 @@ package body Exp_Disp is if Nkind (D) = N_Package_Declaration then Build_Package_Dispatch_Tables (D); - elsif Nkind (D) = N_Package_Body then + elsif Nkind (D) = N_Package_Body + and then Ekind (Corresponding_Spec (D)) /= E_Generic_Package + then Build_Dispatch_Tables (Declarations (D)); elsif Nkind (D) = N_Package_Body_Stub diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 028ee01..8ac1b90 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1523,7 +1523,123 @@ package body Exp_Util is New_E := Type_Map.Get (Entity (N)); if Present (New_E) then - Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + declare + + Ctrl_Type : constant Entity_Id + := Find_Dispatching_Type (Par_Subp); + + function Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Call_Node : Node_Id) return Boolean; + -- If Call_Node is a call to a primitive function F of the + -- tagged type T associated with Par_Subp that either has + -- any actuals that are controlling formals of Par_Subp, + -- or else the call to F is an actual parameter of an + -- enclosing call to a primitive of T that has any actuals + -- that are controlling formals of Par_Subp (and recursively + -- up the tree of enclosing function calls), returns True; + -- otherwise returns False. Returning True implies that the + -- call to F must be mapped to a call that instead targets + -- the corresponding function F of the tagged type for which + -- Subp is a primitive function. + + -------------------------------------------------- + -- Call_To_Parent_Dispatching_Op_Must_Be_Mapped -- + -------------------------------------------------- + + function Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Call_Node : Node_Id) return Boolean + is + pragma Assert (Nkind (Call_Node) = N_Function_Call); + + Actual : Node_Id := First_Actual (Call_Node); + Actual_Or_Prefix : Node_Id; + + begin + if Is_Entity_Name (Name (Call_Node)) + and then Is_Dispatching_Operation + (Entity (Name (Call_Node))) + and then + Is_Ancestor + (Ctrl_Type, + Find_Dispatching_Type + (Entity (Name (Call_Node)))) + then + while Present (Actual) loop + + -- Account for 'Old and explicit dereferences, + -- picking up the prefix object in those cases. + + if (Nkind (Actual) = N_Attribute_Reference + and then Attribute_Name (Actual) = Name_Old) + or else Nkind (Actual) = N_Explicit_Dereference + then + Actual_Or_Prefix := Prefix (Actual); + else + Actual_Or_Prefix := Actual; + end if; + + -- If at least one actual is a controlling formal + -- parameter of a class-wide Pre/Post aspect's + -- subprogram, the rule in RM 6.1.1(7) applies, + -- and we want to map the call to target the + -- corresponding function of the derived type. + + if Nkind (Actual_Or_Prefix) + in N_Identifier + | N_Expanded_Name + | N_Operator_Symbol + + and then Is_Formal (Entity (Actual_Or_Prefix)) + + and then Is_Controlling_Formal + (Entity (Actual_Or_Prefix)) + then + return True; + + -- RM 6.1.1(7) also applies to Result attributes + -- of primitive functions with controlling results. + + elsif Is_Attribute_Result (Actual) + and then Has_Controlling_Result (Subp) + then + return True; + end if; + + Next_Actual (Actual); + end loop; + + if Nkind (Parent (Call_Node)) = N_Function_Call then + return + Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Parent (Call_Node)); + end if; + + return False; + + else + return False; + end if; + end Call_To_Parent_Dispatching_Op_Must_Be_Mapped; + + begin + -- If N's entity is in the map, then the entity is either + -- a formal of the parent subprogram that should necessarily + -- be mapped, or it's a function call's target entity that + -- that should be mapped if the call involves any actuals + -- that reference formals of the parent subprogram (or the + -- function call is part of an enclosing call that similarly + -- qualifies for mapping). Rewrite a node that references + -- any such qualified entity to a new node referencing the + -- corresponding entity associated with the derived type. + + if not Is_Subprogram (Entity (N)) + or else Nkind (Parent (N)) /= N_Function_Call + or else + Call_To_Parent_Dispatching_Op_Must_Be_Mapped (Parent (N)) + then + Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + end if; + end; end if; -- Update type of function call node, which should be the same as diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index ec0fb16e..ce9a974 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -715,10 +715,11 @@ package body Freeze is then declare O_Ent : Entity_Id; + O_Typ : Entity_Id; Off : Boolean; begin - Find_Overlaid_Entity (Addr, O_Ent, Off); + Find_Overlaid_Entity (Addr, O_Ent, O_Typ, Off); if Ekind (O_Ent) = E_Constant and then Etype (O_Ent) = Typ diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index bfa634f..8af261a 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -215,7 +215,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (May_Inherit_Delayed_Rep_Aspects, Flag), Sm (Needs_Debug_Info, Flag), Sm (Never_Set_In_Source, Flag), - Sm (Overlays_Constant, Flag), Sm (Prev_Entity, Node_Id), Sm (Referenced, Flag), Sm (Referenced_As_LHS, Flag), @@ -353,6 +352,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Last_Aggregate_Assignment, Node_Id), Sm (Optimize_Alignment_Space, Flag), Sm (Optimize_Alignment_Time, Flag), + Sm (Overlays_Constant, Flag), Sm (Prival_Link, Node_Id), Sm (Related_Type, Node_Id), Sm (Return_Statement, Node_Id), diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 4d98471..f44260b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -1581,6 +1581,11 @@ and generics may name types with unknown discriminants without using the @code{(<>)} notation. In addition, some but not all of the additional restrictions of Ada 83 are enforced. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + Ada 83 mode is intended for two purposes. Firstly, it allows existing Ada 83 code to be compiled and adapted to GNAT with less effort. Secondly, it aids in keeping code backwards compatible with Ada 83. @@ -1608,6 +1613,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 95 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + @node Pragma Ada_05,Pragma Ada_2005,Pragma Ada_95,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{21} @section Pragma Ada_05 @@ -1626,6 +1636,11 @@ This pragma is useful when writing a reusable component that itself uses Ada 2005 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form (which is not a configuration pragma) is used for managing the transition from Ada 95 to Ada 2005 in the run-time library. If an entity is marked @@ -1671,6 +1686,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 2012 features, but which is intended to be usable from Ada 83, Ada 95, or Ada 2005 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form, which is not a configuration pragma, is used for managing the transition from Ada 2005 to Ada 2012 in the run-time library. If an entity is marked @@ -1716,6 +1736,11 @@ contexts. This pragma is useful when writing a reusable component that itself uses Ada 2022 features, but which is intended to be usable from Ada 83, Ada 95, Ada 2005 or Ada 2012 programs. +Like all configuration pragmas, if the pragma is placed before a library +level package specification it is not propagated to the corresponding +package body (see RM 10.1.5(8)); it must be added explicitly to the +package body. + The one argument form, which is not a configuration pragma, is used for managing the transition from Ada 2012 to Ada 2022 in the run-time library. If an entity is marked diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index ca1d7bc..0a3cdb5 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -2911,6 +2911,10 @@ You can place configuration pragmas either appear at the start of a compilation unit or in a configuration pragma file that applies to all compilations performed in a given compilation environment. +Configuration pragmas placed before a library level package specification +are not propagated to the corresponding package body (see RM 10.1.5(8)); +they must be added explicitly to the package body. + GNAT includes the @code{gnatchop} utility to provide an automatic way to handle configuration pragmas that follows the semantics for compilations (that is, files with multiple units) described in the RM. @@ -29833,8 +29837,8 @@ to permit their use in free software. @printindex ge -@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @anchor{d2}@w{ } +@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @c %**end of body @bye diff --git a/gcc/ada/libgnat/i-cheri.adb b/gcc/ada/libgnat/i-cheri.adb index 37e5c3d..1575705 100644 --- a/gcc/ada/libgnat/i-cheri.adb +++ b/gcc/ada/libgnat/i-cheri.adb @@ -31,6 +31,30 @@ package body Interfaces.CHERI is + ---------------- + -- Set_Bounds -- + ---------------- + + procedure Set_Bounds + (Cap : in out Capability; + Length : Bounds_Length) + is + begin + Cap := Capability_With_Bounds (Cap, Length); + end Set_Bounds; + + ---------------------- + -- Set_Exact_Bounds -- + ---------------------- + + procedure Set_Exact_Bounds + (Cap : in out Capability; + Length : Bounds_Length) + is + begin + Cap := Capability_With_Exact_Bounds (Cap, Length); + end Set_Exact_Bounds; + ---------------------------- -- Set_Address_And_Bounds -- ---------------------------- diff --git a/gcc/ada/libgnat/i-cheri.ads b/gcc/ada/libgnat/i-cheri.ads index ed26e55..4186b6d 100644 --- a/gcc/ada/libgnat/i-cheri.ads +++ b/gcc/ada/libgnat/i-cheri.ads @@ -273,8 +273,7 @@ is (Cap : in out Capability; Length : Bounds_Length) with - Import, Convention => Intrinsic, - External_Name => "__builtin_cheri_bounds_set"; + Inline; -- Narrow the bounds of a capability so that the lower bound is the -- current address and the upper bound is suitable for the Length. -- @@ -287,8 +286,7 @@ is (Cap : in out Capability; Length : Bounds_Length) with - Import, Convention => Intrinsic, - External_Name => "__builtin_cheri_bounds_set_exact"; + Inline; -- Narrow the bounds of a capability so that the lower bound is the -- current address and the upper bound is suitable for the Length. -- diff --git a/gcc/ada/libgnat/s-dorepr.adb b/gcc/ada/libgnat/s-dorepr.adb index ddc7c1d..1d9604a 100644 --- a/gcc/ada/libgnat/s-dorepr.adb +++ b/gcc/ada/libgnat/s-dorepr.adb @@ -134,7 +134,7 @@ package body Product is Ahi, Alo, Bhi, Blo, E : Num; begin - if Is_Infinity (P) or else Is_Zero (P) then + if Is_Infinity_Or_NaN (P) or else Is_Zero (P) then return (P, 0.0); else @@ -157,7 +157,7 @@ package body Product is Hi, Lo, E : Num; begin - if Is_Infinity (Q) or else Is_Zero (Q) then + if Is_Infinity_Or_NaN (Q) or else Is_Zero (Q) then return (Q, 0.0); else diff --git a/gcc/ada/libgnat/s-dorepr__fma.adb b/gcc/ada/libgnat/s-dorepr__fma.adb index 0d3dc53..45a9223 100644 --- a/gcc/ada/libgnat/s-dorepr__fma.adb +++ b/gcc/ada/libgnat/s-dorepr__fma.adb @@ -78,7 +78,7 @@ package body Product is E : Num; begin - if Is_Infinity (P) or else Is_Zero (P) then + if Is_Infinity_Or_NaN (P) or else Is_Zero (P) then return (P, 0.0); else diff --git a/gcc/ada/libgnat/s-dourea.adb b/gcc/ada/libgnat/s-dourea.adb index a37f2eb..68d4d9a 100644 --- a/gcc/ada/libgnat/s-dourea.adb +++ b/gcc/ada/libgnat/s-dourea.adb @@ -34,12 +34,12 @@ package body System.Double_Real is function Is_NaN (N : Num) return Boolean is (N /= N); -- Return True if N is a NaN - function Is_Infinity (N : Num) return Boolean is (Is_NaN (N - N)); - -- Return True if N is an infinity. Used to avoid propagating meaningless - -- errors when the result of a product is an infinity. + function Is_Infinity_Or_NaN (N : Num) return Boolean is (Is_NaN (N - N)); + -- Return True if N is either an infinity or NaN. Used to avoid propagating + -- meaningless errors when the result of a product is an infinity or NaN. function Is_Zero (N : Num) return Boolean is (N = -N); - -- Return True if N is a Zero. Used to preserve the sign when the result of + -- Return True if N is a zero. Used to preserve the sign when the result of -- a product is a zero. package Product is @@ -151,7 +151,7 @@ package body System.Double_Real is P : constant Double_T := Two_Prod (A.Hi, B); begin - if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then + if Is_Infinity_Or_NaN (P.Hi) or else Is_Zero (P.Hi) then return (P.Hi, 0.0); else return Quick_Two_Sum (P.Hi, P.Lo + A.Lo * B); @@ -162,7 +162,7 @@ package body System.Double_Real is P : constant Double_T := Two_Prod (A.Hi, B.Hi); begin - if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then + if Is_Infinity_Or_NaN (P.Hi) or else Is_Zero (P.Hi) then return (P.Hi, 0.0); else return Quick_Two_Sum (P.Hi, P.Lo + A.Hi * B.Lo + A.Lo * B.Hi); @@ -178,7 +178,7 @@ package body System.Double_Real is P, R : Double_T; begin - if Is_Infinity (B) or else Is_Zero (B) then + if Is_Infinity_Or_NaN (B) or else Is_Zero (B) then return (A.Hi / B, 0.0); end if; pragma Annotate (CodePeer, Intentional, "test always false", @@ -202,7 +202,7 @@ package body System.Double_Real is R, S : Double_T; begin - if Is_Infinity (B.Hi) or else Is_Zero (B.Hi) then + if Is_Infinity_Or_NaN (B.Hi) or else Is_Zero (B.Hi) then return (A.Hi / B.Hi, 0.0); end if; pragma Annotate (CodePeer, Intentional, "test always false", @@ -228,7 +228,7 @@ package body System.Double_Real is Q : constant Double_T := Two_Sqr (A.Hi); begin - if Is_Infinity (Q.Hi) or else Is_Zero (Q.Hi) then + if Is_Infinity_Or_NaN (Q.Hi) or else Is_Zero (Q.Hi) then return (Q.Hi, 0.0); else return Quick_Two_Sum (Q.Hi, Q.Lo + 2.0 * A.Hi * A.Lo + A.Lo * A.Lo); diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index f52136c..dbb894f 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -503,6 +503,8 @@ package body Ch13 is or else A_Id = Aspect_Refined_Depends then Inside_Depends := True; + elsif A_Id = Aspect_Abstract_State then + Inside_Abstract_State := True; end if; -- Note that we have seen an Import aspect specification. @@ -529,9 +531,10 @@ package body Ch13 is Set_Expression (Aspect, P_Expression); end if; - -- Unconditionally reset flag for Inside_Depends + -- Unconditionally reset flag for being inside aspects - Inside_Depends := False; + Inside_Depends := False; + Inside_Abstract_State := False; end if; -- Add the aspect to the resulting list only when it was properly diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 20640d55..11c9a83 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -385,6 +385,8 @@ package body Ch2 is or else Chars (Ident_Node) = Name_Refined_Depends then Inside_Depends := True; + elsif Chars (Ident_Node) = Name_Abstract_State then + Inside_Abstract_State := True; end if; -- Scan arguments. We assume that arguments are present if there is @@ -441,11 +443,11 @@ package body Ch2 is Semicolon_Loc := Token_Ptr; - -- Cancel indication of being within a pragma or in particular a Depends - -- pragma. + -- Cancel indication of being within a pragma - Inside_Depends := False; - Inside_Pragma := False; + Inside_Depends := False; + Inside_Abstract_State := False; + Inside_Pragma := False; -- Now we have two tasks left, we need to scan out the semicolon -- following the pragma, and we have to call Par.Prag to process @@ -472,8 +474,9 @@ package body Ch2 is exception when Error_Resync => Resync_Past_Semicolon; - Inside_Depends := False; - Inside_Pragma := False; + Inside_Depends := False; + Inside_Abstract_State := False; + Inside_Pragma := False; return Error; end P_Pragma; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 8267a0c..ebdc587 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -668,13 +668,13 @@ package body Ch4 is -- (discrete_range) - -- This is a slice. This case is handled in LP_State_Init + -- This is a slice -- (expression, expression, ..) -- This is interpreted as an indexed component, i.e. as a -- case of a name which can be extended in the normal manner. - -- This case is handled by LP_State_Name or LP_State_Expr. + -- This case is handled by LP_State_Expr. -- Note: if and case expressions (without an extra level of -- parentheses) are permitted in this context). @@ -935,129 +935,9 @@ package body Ch4 is -- Error recovery: cannot raise Error_Resync - function P_Function_Name return Node_Id is - Designator_Node : Node_Id; - Prefix_Node : Node_Id; - Selector_Node : Node_Id; - Dot_Sloc : Source_Ptr := No_Location; - - begin - -- Prefix_Node is set to the gathered prefix so far, Empty means that - -- no prefix has been scanned. This allows us to build up the result - -- in the required right recursive manner. - - Prefix_Node := Empty; - - -- Loop through prefixes - - loop - Designator_Node := Token_Node; - - if Token not in Token_Class_Desig then - return P_Identifier; -- let P_Identifier issue the error message - - else -- Token in Token_Class_Desig - Scan; -- past designator - exit when Token /= Tok_Dot; - end if; - - -- Here at a dot, with token just before it in Designator_Node - - if No (Prefix_Node) then - Prefix_Node := Designator_Node; - else - Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); - Set_Prefix (Selector_Node, Prefix_Node); - Set_Selector_Name (Selector_Node, Designator_Node); - Prefix_Node := Selector_Node; - end if; - - Dot_Sloc := Token_Ptr; - Scan; -- past dot - end loop; - - -- Fall out of the loop having just scanned a designator - - if No (Prefix_Node) then - return Designator_Node; - else - Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); - Set_Prefix (Selector_Node, Prefix_Node); - Set_Selector_Name (Selector_Node, Designator_Node); - return Selector_Node; - end if; - - exception - when Error_Resync => - return Error; - end P_Function_Name; - - -- This function parses a restricted form of Names which are either - -- identifiers, or identifiers preceded by a sequence of prefixes - -- that are direct names. - - -- Error recovery: cannot raise Error_Resync - function P_Qualified_Simple_Name return Node_Id is - Designator_Node : Node_Id; - Prefix_Node : Node_Id; - Selector_Node : Node_Id; - Dot_Sloc : Source_Ptr := No_Location; - begin - -- Prefix node is set to the gathered prefix so far, Empty means that - -- no prefix has been scanned. This allows us to build up the result - -- in the required right recursive manner. - - Prefix_Node := Empty; - - -- Loop through prefixes - - loop - Designator_Node := Token_Node; - - if Token = Tok_Identifier then - Scan; -- past identifier - exit when Token /= Tok_Dot; - - elsif Token not in Token_Class_Desig then - return P_Identifier; -- let P_Identifier issue the error message - - else - Scan; -- past designator - - if Token /= Tok_Dot then - Error_Msg_SP ("identifier expected"); - return Error; - end if; - end if; - - -- Here at a dot, with token just before it in Designator_Node - - if No (Prefix_Node) then - Prefix_Node := Designator_Node; - else - Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); - Set_Prefix (Selector_Node, Prefix_Node); - Set_Selector_Name (Selector_Node, Designator_Node); - Prefix_Node := Selector_Node; - end if; - - Dot_Sloc := Token_Ptr; - Scan; -- past dot - end loop; - - -- Fall out of the loop having just scanned an identifier - - if No (Prefix_Node) then - return Designator_Node; - else - Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); - Set_Prefix (Selector_Node, Prefix_Node); - Set_Selector_Name (Selector_Node, Designator_Node); - return Selector_Node; - end if; - + return P_Qualified_Simple_Name_Resync; exception when Error_Resync => return Error; @@ -1076,6 +956,10 @@ package body Ch4 is Dot_Sloc : Source_Ptr := No_Location; begin + -- Prefix_Node is set to the gathered prefix so far, Empty means that + -- no prefix has been scanned. This allows us to build up the result + -- in the required right recursive manner. + Prefix_Node := Empty; -- Loop through prefixes @@ -1083,21 +967,13 @@ package body Ch4 is loop Designator_Node := Token_Node; - if Token = Tok_Identifier then - Scan; -- past identifier - exit when Token /= Tok_Dot; - - elsif Token not in Token_Class_Desig then + if Token not in Token_Class_Desig then Discard_Junk_Node (P_Identifier); -- to issue the error message raise Error_Resync; else Scan; -- past designator - - if Token /= Tok_Dot then - Error_Msg_SP ("identifier expected"); - raise Error_Resync; - end if; + exit when Token /= Tok_Dot; end if; -- Here at a dot, with token just before it in Designator_Node @@ -1112,7 +988,7 @@ package body Ch4 is end if; Dot_Sloc := Token_Ptr; - Scan; -- past period + Scan; -- past dot end loop; -- Fall out of the loop having just scanned an identifier @@ -1607,8 +1483,13 @@ package body Ch4 is -- Improper use of WITH elsif Token = Tok_With then - Error_Msg_SC ("WITH must be preceded by single expression in " & - "extension aggregate"); + if Inside_Abstract_State then + Error_Msg_SC ("state name with options must be enclosed in " & + "parentheses"); + else + Error_Msg_SC ("WITH must be preceded by single expression in " & + "extension aggregate"); + end if; raise Error_Resync; -- Range attribute can only appear as part of a discrete choice list diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 55591fd..0f7765b 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -362,12 +362,11 @@ package body Ch6 is if Func then Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); - Set_Name (Inst_Node, P_Function_Name); else Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc); - Set_Name (Inst_Node, P_Qualified_Simple_Name); end if; + Set_Name (Inst_Node, P_Qualified_Simple_Name); Set_Defining_Unit_Name (Inst_Node, Name_Node); Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); P_Aspect_Specifications (Inst_Node, Semicolon => True); diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 5d61fac..e11ec7e 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -80,6 +80,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- True within a delta aggregate (but only after the "delta" token has -- been scanned). Used to distinguish syntax errors from syntactically -- correct "deep" delta aggregates (enabled via -gnatX0). + + Inside_Abstract_State : Boolean := False; + -- True within an Abstract_State contract. Used to distinguish syntax error + -- about extended aggregates and about a malformed contract. + Save_Style_Checks : Style_Check_Options; Save_Style_Check : Boolean; -- Variables for storing the original state of whether style checks should @@ -825,7 +830,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Aggregate return Node_Id; function P_Expression return Node_Id; function P_Expression_Or_Range_Attribute return Node_Id; - function P_Function_Name return Node_Id; function P_Name return Node_Id; function P_Qualified_Simple_Name return Node_Id; function P_Qualified_Simple_Name_Resync return Node_Id; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 06df00e..449fd8a 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -765,12 +765,11 @@ package body Sem is E : constant Entity_Id := Defining_Entity_Or_Empty (N); begin if Present (E) then - if Ekind (E) = E_Void - and then Nkind (N) = N_Component_Declaration + if Nkind (N) = N_Component_Declaration and then Present (Scope (E)) and then Ekind (Scope (E)) = E_Record_Type then - null; -- Set it later, in Analyze_Component_Declaration + null; -- Set it later, in Record_Type_Definition elsif not Is_Not_Self_Hidden (E) then Set_Is_Not_Self_Hidden (E); end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bf4d684..d4034d2 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5693,19 +5693,15 @@ package body Sem_Attr is when Attribute_Partition_ID => Check_E0; - if P_Type /= Any_Type then - if not Is_Library_Level_Entity (Entity (P)) then - Error_Attr_P - ("prefix of % attribute must be library-level entity"); + if not Is_Library_Level_Entity (Entity (P)) then + Error_Attr_P + ("prefix of % attribute must be library-level entity"); - -- The defining entity of prefix should not be declared inside a - -- Pure unit. RM E.1(8). Is_Pure was set during declaration. + -- The defining entity of prefix should not be declared inside a + -- Pure unit. RM E.1(8). Is_Pure was set during declaration. - elsif Is_Entity_Name (P) - and then Is_Pure (Entity (P)) - then - Error_Attr_P ("prefix of% attribute must not be declared pure"); - end if; + elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) then + Error_Attr_P ("prefix of% attribute must not be declared pure"); end if; Set_Etype (N, Universal_Integer); diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 25bba9b..45aabad 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1225,9 +1225,15 @@ package body Sem_Ch10 is if Expander_Active and then Tagged_Type_Expansion then case Nkind (Unit_Node) is - when N_Package_Declaration | N_Package_Body => + when N_Package_Declaration => Build_Static_Dispatch_Tables (Unit_Node); + when N_Package_Body => + if Ekind (Corresponding_Spec (Unit_Node)) /= E_Generic_Package + then + Build_Static_Dispatch_Tables (Unit_Node); + end if; + when N_Package_Instantiation => Build_Static_Dispatch_Tables (Instance_Spec (Unit_Node)); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3a31a92..c9b9e7f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -14129,6 +14129,16 @@ package body Sem_Ch12 is T2 := Etype (I2); end if; + -- In the case of a fixed-lower-bound subtype, we want to check + -- against the index type's range rather than the range of the + -- subtype (which will be seen as unconstrained, and whose bounds + -- won't generally match those of the formal unconstrained array + -- type's corresponding index type). + + if Is_Fixed_Lower_Bound_Index_Subtype (T2) then + T2 := Etype (Scalar_Range (T2)); + end if; + if not Subtypes_Match (Find_Actual_Type (Etype (I1), A_Gen_T), T2) then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 76a8c0b..22575f9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6208,6 +6208,7 @@ package body Sem_Ch13 is declare Expr : constant Node_Id := Expression (N); O_Ent : Entity_Id; + O_Typ : Entity_Id; Off : Boolean; begin @@ -6220,7 +6221,7 @@ package body Sem_Ch13 is return; end if; - Find_Overlaid_Entity (N, O_Ent, Off); + Find_Overlaid_Entity (N, O_Ent, O_Typ, Off); if Present (O_Ent) then @@ -6273,10 +6274,10 @@ package body Sem_Ch13 is if (Is_Record_Type (Etype (U_Ent)) or else Is_Array_Type (Etype (U_Ent))) - and then (Is_Record_Type (Etype (O_Ent)) - or else Is_Array_Type (Etype (O_Ent))) + and then (Is_Record_Type (O_Typ) + or else Is_Array_Type (O_Typ)) and then Reverse_Storage_Order (Etype (U_Ent)) /= - Reverse_Storage_Order (Etype (O_Ent)) + Reverse_Storage_Order (O_Typ) then Error_Msg_N ("??overlay changes scalar storage order", Expr); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 690d668..1263d70 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2046,6 +2046,7 @@ package body Sem_Ch3 is -- Start of processing for Analyze_Component_Declaration begin + Mutate_Ekind (Id, E_Component); Generate_Definition (Id); Enter_Name (Id); @@ -4364,6 +4365,12 @@ package body Sem_Ch3 is -- Start of processing for Analyze_Object_Declaration begin + if Constant_Present (N) then + Mutate_Ekind (Id, E_Constant); + else + Mutate_Ekind (Id, E_Variable); + end if; + -- There are three kinds of implicit types generated by an -- object declaration: @@ -4443,7 +4450,6 @@ package body Sem_Ch3 is T := Find_Type_Of_Object (Object_Definition (N), N); Set_Etype (Id, T); - Mutate_Ekind (Id, E_Variable); goto Leave; end if; @@ -4469,7 +4475,6 @@ package body Sem_Ch3 is if Error_Posted (Id) then Set_Etype (Id, T); - Mutate_Ekind (Id, E_Variable); goto Leave; end if; end if; @@ -4552,7 +4557,6 @@ package body Sem_Ch3 is Error_Msg_N ("\declaration requires an initialization expression", N); - Set_Constant_Present (N, False); -- In Ada 83, deferred constant must be of private type @@ -4659,9 +4663,7 @@ package body Sem_Ch3 is Set_Has_Completion (Id); end if; - -- Set type and resolve (type may be overridden later on). Note: - -- Ekind (Id) must still be E_Void at this point so that incorrect - -- early usage within E is properly diagnosed. + -- Set type and resolve (type may be overridden later on) Set_Etype (Id, T); @@ -4761,7 +4763,6 @@ package body Sem_Ch3 is and then In_Subrange_Of (Etype (Entity (E)), T) then Set_Is_Known_Valid (Id); - Mutate_Ekind (Id, E_Constant); Set_Actual_Subtype (Id, Etype (Entity (E))); end if; @@ -5010,12 +5011,6 @@ package body Sem_Ch3 is -- for discriminants and are thus not indefinite. elsif Is_Unchecked_Union (T) then - if Constant_Present (N) or else Nkind (E) = N_Function_Call then - Mutate_Ekind (Id, E_Constant); - else - Mutate_Ekind (Id, E_Variable); - end if; - -- If the expression is an aggregate it contains the required -- discriminant values but it has not been resolved yet, so do -- it now, and treat it as the initial expression of an object @@ -5076,10 +5071,8 @@ package body Sem_Ch3 is -- "X : Integer := X;". if Constant_Present (N) then - Mutate_Ekind (Id, E_Constant); Set_Is_True_Constant (Id); else - Mutate_Ekind (Id, E_Variable); if Present (E) then Set_Has_Initial_Value (Id); end if; @@ -5221,12 +5214,9 @@ package body Sem_Ch3 is end if; if Constant_Present (N) then - Mutate_Ekind (Id, E_Constant); Set_Is_True_Constant (Id); else - Mutate_Ekind (Id, E_Variable); - -- A variable is set as shared passive if it appears in a shared -- passive package, and is at the outer level. This is not done for -- entities generated during expansion, because those are always @@ -5779,7 +5769,13 @@ package body Sem_Ch3 is Enter_Name (Id); end if; - T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); + T := + Process_Subtype + (Subtype_Indication (N), + N, + Id, + 'P', + Excludes_Null => Null_Exclusion_Present (N)); -- Class-wide equivalent types of records with unknown discriminants -- involve the generation of an itype which serves as the private view @@ -6596,7 +6592,13 @@ package body Sem_Ch3 is -- Process subtype indication if one is present if Present (Component_Typ) then - Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C'); + Element_Type := + Process_Subtype + (Component_Typ, + P, + Related_Id, + 'C', + Excludes_Null => Null_Exclusion_Present (Component_Def)); Set_Etype (Component_Typ, Element_Type); -- Ada 2005 (AI-230): Access Definition case @@ -7212,7 +7214,11 @@ package body Sem_Ch3 is Set_Directly_Designated_Type (Derived_Type, Designated_Type (Parent_Type)); - Subt := Process_Subtype (S, N); + Subt := + Process_Subtype + (S, + N, + Excludes_Null => Null_Exclusion_Present (Type_Definition (N))); if Nkind (S) /= N_Subtype_Indication and then Subt /= Base_Type (Subt) @@ -15093,7 +15099,8 @@ package body Sem_Ch3 is -- If this is a range for a fixed-lower-bound subtype, then set the -- index itype's low bound to the FLB and the index itype's upper bound -- to the high bound of the parent array type's index subtype. Also, - -- mark the itype as an FLB index subtype. + -- set the Etype of the new scalar range and mark the itype as an FLB + -- index subtype. if Nkind (S) = N_Range and then Is_FLB_Index then Set_Scalar_Range @@ -15101,6 +15108,7 @@ package body Sem_Ch3 is Make_Range (Sloc (S), Low_Bound => Low_Bound (S), High_Bound => Type_High_Bound (T))); + Set_Etype (Scalar_Range (Def_Id), Etype (Index)); Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id); else @@ -18836,7 +18844,11 @@ package body Sem_Ch3 is -- Otherwise, the object definition is just a subtype_mark else - T := Process_Subtype (Obj_Def, Related_Nod); + T := + Process_Subtype + (Obj_Def, + Related_Nod, + Excludes_Null => Null_Exclusion_Present (Parent (Obj_Def))); end if; return T; @@ -19844,7 +19856,9 @@ package body Sem_Ch3 is -- Start of processing for Is_Visible_Component begin - if Ekind (C) in E_Component | E_Discriminant then + if Ekind (C) in E_Component | E_Discriminant + and then Is_Not_Self_Hidden (C) + then Original_Comp := Original_Record_Component (C); end if; @@ -22509,10 +22523,11 @@ package body Sem_Ch3 is --------------------- function Process_Subtype - (S : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id := Empty; - Suffix : Character := ' ') return Entity_Id + (S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' '; + Excludes_Null : Boolean := False) return Entity_Id is procedure Check_Incomplete (T : Node_Id); -- Called to verify that an incomplete type is not used prematurely @@ -22546,8 +22561,6 @@ package body Sem_Ch3 is Full_View_Id : Entity_Id; Subtype_Mark_Id : Entity_Id; - May_Have_Null_Exclusion : Boolean; - -- Start of processing for Process_Subtype begin @@ -22568,98 +22581,59 @@ package body Sem_Ch3 is Check_Incomplete (S); P := Parent (S); - -- The following mirroring of assertion in Null_Exclusion_Present is - -- ugly, can't we have a range, a static predicate or even a flag??? - - May_Have_Null_Exclusion := - Present (P) - and then - Nkind (P) in N_Access_Definition - | N_Access_Function_Definition - | N_Access_Procedure_Definition - | N_Access_To_Object_Definition - | N_Allocator - | N_Component_Definition - | N_Derived_Type_Definition - | N_Discriminant_Specification - | N_Formal_Object_Declaration - | N_Function_Specification - | N_Object_Declaration - | N_Object_Renaming_Declaration - | N_Parameter_Specification - | N_Subtype_Declaration; - - -- Ada 2005 (AI-231): Static check - - if Ada_Version >= Ada_2005 - and then May_Have_Null_Exclusion - and then Null_Exclusion_Present (P) - and then Nkind (P) /= N_Access_To_Object_Definition - and then not Is_Access_Type (Entity (S)) - then - Error_Msg_N ("`NOT NULL` only allowed for an access type", S); - end if; - - -- Create an Itype that is a duplicate of Entity (S) but with the - -- null-exclusion attribute. - - if May_Have_Null_Exclusion - and then Is_Access_Type (Entity (S)) - and then Null_Exclusion_Present (P) + if Excludes_Null then + -- Create an Itype that is a duplicate of Entity (S) but with the + -- null-exclusion attribute. + if Is_Access_Type (Entity (S)) then + if Can_Never_Be_Null (Entity (S)) then + case Nkind (Related_Nod) is + when N_Full_Type_Declaration => + if Nkind (Type_Definition (Related_Nod)) + in N_Array_Type_Definition + then + Error_Node := + Subtype_Indication + (Component_Definition + (Type_Definition (Related_Nod))); + else + Error_Node := + Subtype_Indication + (Type_Definition (Related_Nod)); + end if; - -- No need to check the case of an access to object definition. - -- It is correct to define double not-null pointers. + when N_Subtype_Declaration => + Error_Node := Subtype_Indication (Related_Nod); - -- Example: - -- type Not_Null_Int_Ptr is not null access Integer; - -- type Acc is not null access Not_Null_Int_Ptr; + when N_Object_Declaration => + Error_Node := Object_Definition (Related_Nod); - and then Nkind (P) /= N_Access_To_Object_Definition - then - if Can_Never_Be_Null (Entity (S)) then - case Nkind (Related_Nod) is - when N_Full_Type_Declaration => - if Nkind (Type_Definition (Related_Nod)) - in N_Array_Type_Definition - then + when N_Component_Declaration => Error_Node := Subtype_Indication - (Component_Definition - (Type_Definition (Related_Nod))); - else - Error_Node := - Subtype_Indication (Type_Definition (Related_Nod)); - end if; - - when N_Subtype_Declaration => - Error_Node := Subtype_Indication (Related_Nod); - - when N_Object_Declaration => - Error_Node := Object_Definition (Related_Nod); + (Component_Definition (Related_Nod)); - when N_Component_Declaration => - Error_Node := - Subtype_Indication (Component_Definition (Related_Nod)); + when N_Allocator => + Error_Node := Expression (Related_Nod); - when N_Allocator => - Error_Node := Expression (Related_Nod); + when others => + pragma Assert (False); + Error_Node := Related_Nod; + end case; - when others => - pragma Assert (False); - Error_Node := Related_Nod; - end case; + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Error_Node, + Entity (S)); + end if; - Error_Msg_NE - ("`NOT NULL` not allowed (& already excludes null)", - Error_Node, - Entity (S)); + Set_Etype + (S, + Create_Null_Excluding_Itype + (T => Entity (S), Related_Nod => P)); + Set_Entity (S, Etype (S)); + elsif Ada_Version >= Ada_2005 then + Error_Msg_N ("`NOT NULL` only allowed for an access type", S); end if; - - Set_Etype (S, - Create_Null_Excluding_Itype - (T => Entity (S), - Related_Nod => P)); - Set_Entity (S, Etype (S)); end if; return Entity (S); @@ -23134,10 +23108,8 @@ package body Sem_Ch3 is Component := First_Entity (Current_Scope); while Present (Component) loop - if Ekind (Component) = E_Void - and then not Is_Itype (Component) + if Ekind (Component) = E_Component and then not Is_Itype (Component) then - Mutate_Ekind (Component, E_Component); Reinit_Component_Location (Component); Set_Is_Not_Self_Hidden (Component); end if; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 00a6fa77..d600d15 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -301,10 +301,11 @@ package Sem_Ch3 is -- in this case the bounds are captured if necessary using this name. function Process_Subtype - (S : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id := Empty; - Suffix : Character := ' ') return Entity_Id; + (S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' '; + Excludes_Null : Boolean := False) return Entity_Id; -- Process a subtype indication S and return corresponding entity. -- Related_Nod is the node where the potential generated implicit types -- will be inserted. The Related_Id and Suffix parameters are used to diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9a1784f..ec48edd 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -728,7 +728,8 @@ package body Sem_Ch4 is end; end if; - Type_Id := Process_Subtype (E, N); + Type_Id := + Process_Subtype (E, N, Excludes_Null => Null_Exclusion_Present (N)); Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Type_Id); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 91321710..a142a1c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -225,7 +225,10 @@ package body Sem_Ch6 is -- Create the declaration for an inequality operator that is implicitly -- created by a user-defined equality operator that yields a boolean. - procedure Set_Formal_Mode (Formal_Id : Entity_Id); + procedure Set_Formal_Mode + (Formal_Id : Entity_Id; + Spec : N_Parameter_Specification_Id; + Subp_Id : Entity_Id); -- Set proper Ekind to reflect formal mode (in, out, in out), and set -- miscellaneous other attributes. @@ -13066,13 +13069,10 @@ package body Sem_Ch6 is -- Start of processing for Process_Formals begin - -- In order to prevent premature use of the formals in the same formal - -- part, the Ekind is left undefined until all default expressions are - -- analyzed. The Ekind is established in a separate loop at the end. - Param_Spec := First (T); while Present (Param_Spec) loop Formal := Defining_Identifier (Param_Spec); + Set_Formal_Mode (Formal, Param_Spec, Current_Scope); Set_Never_Set_In_Source (Formal, True); Enter_Name (Formal); @@ -13390,12 +13390,48 @@ package body Sem_Ch6 is Analyze_Return_Type (Related_Nod); end if; - -- Now set the kind (mode) of each formal - Param_Spec := First (T); while Present (Param_Spec) loop Formal := Defining_Identifier (Param_Spec); - Set_Formal_Mode (Formal); + Set_Is_Not_Self_Hidden (Formal); + + -- Set Is_Known_Non_Null for access parameters since the language + -- guarantees that access parameters are always non-null. We also set + -- Can_Never_Be_Null, since there is no way to change the value. + + if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition then + + -- Ada 2005 (AI-231): In Ada 95, access parameters are always non- + -- null; In Ada 2005, only if then null_exclusion is explicit. + + if Ada_Version < Ada_2005 + or else Can_Never_Be_Null (Etype (Formal)) + then + Set_Is_Known_Non_Null (Formal); + Set_Can_Never_Be_Null (Formal); + end if; + + -- Ada 2005 (AI-231): Null-exclusion access subtype + + elsif Is_Access_Type (Etype (Formal)) + and then Can_Never_Be_Null (Etype (Formal)) + then + Set_Is_Known_Non_Null (Formal); + + -- We can also set Can_Never_Be_Null (thus preventing some junk + -- access checks) for the case of an IN parameter, which cannot + -- be changed, or for an IN OUT parameter, which can be changed + -- but not to a null value. But for an OUT parameter, the initial + -- value passed in can be null, so we can't set this flag in that + -- case. + + if Ekind (Formal) /= E_Out_Parameter then + Set_Can_Never_Be_Null (Formal); + end if; + end if; + + Set_Mechanism (Formal, Default_Mechanism); + Set_Formal_Validity (Formal); if Ekind (Formal) = E_In_Parameter then Default := Expression (Param_Spec); @@ -13666,23 +13702,23 @@ package body Sem_Ch6 is -- Set_Formal_Mode -- --------------------- - procedure Set_Formal_Mode (Formal_Id : Entity_Id) is - Spec : constant Node_Id := Parent (Formal_Id); - Id : constant Entity_Id := Scope (Formal_Id); - + procedure Set_Formal_Mode + (Formal_Id : Entity_Id; + Spec : N_Parameter_Specification_Id; + Subp_Id : Entity_Id) is begin -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters -- since we ensure that corresponding actuals are always valid at the -- point of the call. if Out_Present (Spec) then - if Is_Entry (Id) - or else Is_Subprogram_Or_Generic_Subprogram (Id) + if Is_Entry (Subp_Id) + or else Is_Subprogram_Or_Generic_Subprogram (Subp_Id) then - Set_Has_Out_Or_In_Out_Parameter (Id, True); + Set_Has_Out_Or_In_Out_Parameter (Subp_Id, True); end if; - if Ekind (Id) in E_Function | E_Generic_Function then + if Ekind (Subp_Id) in E_Function | E_Generic_Function then -- [IN] OUT parameters allowed for functions in Ada 2012 @@ -13719,45 +13755,6 @@ package body Sem_Ch6 is else Mutate_Ekind (Formal_Id, E_In_Parameter); end if; - - Set_Is_Not_Self_Hidden (Formal_Id); - - -- Set Is_Known_Non_Null for access parameters since the language - -- guarantees that access parameters are always non-null. We also set - -- Can_Never_Be_Null, since there is no way to change the value. - - if Nkind (Parameter_Type (Spec)) = N_Access_Definition then - - -- Ada 2005 (AI-231): In Ada 95, access parameters are always non- - -- null; In Ada 2005, only if then null_exclusion is explicit. - - if Ada_Version < Ada_2005 - or else Can_Never_Be_Null (Etype (Formal_Id)) - then - Set_Is_Known_Non_Null (Formal_Id); - Set_Can_Never_Be_Null (Formal_Id); - end if; - - -- Ada 2005 (AI-231): Null-exclusion access subtype - - elsif Is_Access_Type (Etype (Formal_Id)) - and then Can_Never_Be_Null (Etype (Formal_Id)) - then - Set_Is_Known_Non_Null (Formal_Id); - - -- We can also set Can_Never_Be_Null (thus preventing some junk - -- access checks) for the case of an IN parameter, which cannot - -- be changed, or for an IN OUT parameter, which can be changed but - -- not to a null value. But for an OUT parameter, the initial value - -- passed in can be null, so we can't set this flag in that case. - - if Ekind (Formal_Id) /= E_Out_Parameter then - Set_Can_Never_Be_Null (Formal_Id); - end if; - end if; - - Set_Mechanism (Formal_Id, Default_Mechanism); - Set_Formal_Validity (Formal_Id); end Set_Formal_Mode; ------------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index fe93288..db892d0 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -8404,7 +8404,8 @@ package body Sem_Ch8 is if Is_Overloaded (P) then - -- The prefix must resolve to a unique enclosing construct + -- The prefix must resolve to a unique enclosing construct, per + -- the last sentence of RM 4.1.3 (13). declare Found : Boolean := False; @@ -8418,6 +8419,7 @@ package body Sem_Ch8 is if Found then Error_Msg_N ( "prefix must be unique enclosing scope", N); + Change_Selected_Component_To_Expanded_Name (N); Set_Entity (N, Any_Id); Set_Etype (N, Any_Type); return; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4090d0c..688ccc7 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -14677,19 +14677,18 @@ package body Sem_Prag is D := Declaration_Node (E); - if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E)) + if (Nkind (D) in N_Full_Type_Declaration + | N_Formal_Type_Declaration + and then Is_Array_Type (E)) or else (Nkind (D) = N_Object_Declaration and then Ekind (E) in E_Constant | E_Variable and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition) - or else - (Ada_Version >= Ada_2022 - and then Nkind (D) = N_Formal_Type_Declaration) then -- The flag is set on the base type, or on the object - if Nkind (D) = N_Full_Type_Declaration then + if Is_Array_Type (E) then E := Base_Type (E); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0ce9e95..3c80d23 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8082,20 +8082,7 @@ package body Sem_Util is -- If we fall through, declaration is OK, at least OK enough to continue - -- If Def_Id is a discriminant or a record component we are in the midst - -- of inheriting components in a derived record definition. Preserve - -- their Ekind and Etype. - - if Ekind (Def_Id) in E_Discriminant | E_Component then - null; - - -- If a type is already set, leave it alone (happens when a type - -- declaration is reanalyzed following a call to the optimizer). - - elsif Present (Etype (Def_Id)) then - null; - - else + if No (Etype (Def_Id)) then Set_Etype (Def_Id, Any_Type); -- avoid cascaded errors end if; @@ -8923,9 +8910,10 @@ package body Sem_Util is -------------------------- procedure Find_Overlaid_Entity - (N : Node_Id; - Ent : out Entity_Id; - Off : out Boolean) + (N : Node_Id; + Ent : out Entity_Id; + Ovrl_Typ : out Entity_Id; + Off : out Boolean) is pragma Assert (Nkind (N) = N_Attribute_Definition_Clause @@ -8947,8 +8935,9 @@ package body Sem_Util is -- In the second case, the expr is either Y'Address, or recursively a -- constant that eventually references Y'Address. - Ent := Empty; - Off := False; + Ent := Empty; + Ovrl_Typ := Empty; + Off := False; Expr := Expression (N); @@ -8978,6 +8967,8 @@ package body Sem_Util is end if; end loop; + Ovrl_Typ := Etype (Expr); + -- This loop checks the form of the prefix for an entity, using -- recursion to deal with intermediate components. @@ -8996,8 +8987,10 @@ package body Sem_Util is pragma Assert (not Expander_Active and then Is_Concurrent_Type (Scope (Ent))); - Ent := Empty; + Ent := Empty; + Ovrl_Typ := Empty; end if; + return; -- Check for components @@ -18382,6 +18375,7 @@ package body Sem_Util is case Nkind (N) is when N_Indexed_Component + | N_Selected_Component | N_Slice => return @@ -18393,13 +18387,6 @@ package body Sem_Util is when N_Attribute_Reference => return Attribute_Name (N) in Name_Input | Name_Old | Name_Result; - when N_Selected_Component => - return - Is_Name_Reference (Selector_Name (N)) - and then - (Is_Name_Reference (Prefix (N)) - or else Is_Access_Type (Etype (Prefix (N)))); - when N_Explicit_Dereference => return True; @@ -21907,7 +21894,7 @@ package body Sem_Util is Set_Last_Assignment (Ent, Empty); end if; - if Is_Object (Ent) then + if Is_Object (Ent) and then Ekind (Ent) not in Record_Field_Kind then if not Last_Assignment_Only then Kill_Checks (Ent); Set_Current_Value (Ent, Empty); @@ -25593,16 +25580,18 @@ package body Sem_Util is if Sure and then Modification_Comes_From_Source + and then Ekind (Ent) in E_Constant | E_Variable and then Overlays_Constant (Ent) and then Address_Clause_Overlay_Warnings then declare Addr : constant Node_Id := Address_Clause (Ent); O_Ent : Entity_Id; + O_Typ : Entity_Id; Off : Boolean; begin - Find_Overlaid_Entity (Addr, O_Ent, Off); + Find_Overlaid_Entity (Addr, O_Ent, O_Typ, Off); Error_Msg_Sloc := Sloc (Addr); Error_Msg_NE @@ -28522,12 +28511,6 @@ package body Sem_Util is return False; end if; - if Ekind (Entity (Selector_Name (N))) not in - E_Component | E_Discriminant - then - return False; - end if; - declare Comp : constant Entity_Id := Original_Record_Component (Entity (Selector_Name (N))); @@ -29050,9 +29033,10 @@ package body Sem_Util is ------------------------------ function Ultimate_Overlaid_Entity (E : Entity_Id) return Entity_Id is - Address : Node_Id; - Alias : Entity_Id := E; - Offset : Boolean; + Address : Node_Id; + Alias : Entity_Id := E; + Offset : Boolean; + Ovrl_Typ : Entity_Id; begin -- Currently this routine is only called for stand-alone objects that @@ -29064,7 +29048,7 @@ package body Sem_Util is loop Address := Address_Clause (Alias); if Present (Address) then - Find_Overlaid_Entity (Address, Alias, Offset); + Find_Overlaid_Entity (Address, Alias, Ovrl_Typ, Offset); if Present (Alias) then null; else diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 38e9676..0e97806 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -619,7 +619,21 @@ package Sem_Util is -- Find whether there is a previous definition for name or identifier N in -- the current scope. Because declarations for a scope are not necessarily -- contiguous (e.g. for packages) the first entry on the visibility chain - -- for N is not necessarily in the current scope. + -- for N is not necessarily in the current scope. Take, for example: + -- + -- package P is + -- X : constant := 13; + -- + -- package Q is + -- X : constant := 67; + -- end Q; + -- + -- Y : constant := X; + -- end P; + -- + -- When the declaration of Y is analyzed, the first entry on the visibility + -- chain is the X equal to 67, but Current_Entity_In_Scope returns the X + -- equal to 13. function Current_Scope return Entity_Id; -- Get entity representing current scope @@ -884,14 +898,18 @@ package Sem_Util is -- loop are nested within the block. procedure Find_Overlaid_Entity - (N : Node_Id; - Ent : out Entity_Id; - Off : out Boolean); + (N : Node_Id; + Ent : out Entity_Id; + Ovrl_Typ : out Entity_Id; + Off : out Boolean); -- The node N should be an address representation clause. Determines if the -- target expression is the address of an entity with an optional offset. -- If so, set Ent to the entity and, if there is an offset, set Off to -- True, otherwise to False. If it is not possible to determine that the -- address is of this form, then set Ent to Empty. + -- Ovrl_Typ is set to the type being overlaid and can be different than the + -- type of Ent, for example when the address clause is applied to a record + -- component or to an element of an array. function Find_Parameter_Type (Param : Node_Id) return Entity_Id; -- Return the type of formal parameter Param as determined by its |