diff options
author | Martin Liska <mliska@suse.cz> | 2022-11-07 08:24:48 +0100 |
---|---|---|
committer | Martin Liska <mliska@suse.cz> | 2022-11-07 08:24:48 +0100 |
commit | 1b09b78ee61bd921ae78ebd0f7905b95b9e1c903 (patch) | |
tree | 9c04b59cdd2cd460f0727501d15402d31ffcf5a4 /gcc/ada | |
parent | 1eb021edb27e26f95cda63df121f6bc951647599 (diff) | |
parent | c4f8f8afd07680f9e718de1331cd09607bdd9ac8 (diff) | |
download | gcc-1b09b78ee61bd921ae78ebd0f7905b95b9e1c903.zip gcc-1b09b78ee61bd921ae78ebd0f7905b95b9e1c903.tar.gz gcc-1b09b78ee61bd921ae78ebd0f7905b95b9e1c903.tar.bz2 |
Merge branch 'master' into devel/sphinx
Diffstat (limited to 'gcc/ada')
61 files changed, 849 insertions, 1211 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e13486a..4b0877b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,248 @@ +2022-11-04 Justin Squirek <squirek@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Skip operand + validity checks for attributes Has_Same_Storage and + Overlaps_Storage. + +2022-11-04 Eric Botcazou <ebotcazou@adacore.com> + + * errout.adb (Remove_Warning_Messages.Check_For_Warning): Do not + reinstate the Original_Node in the tree. + * exp_aggr.adb (Build_Array_Aggr_Code.Gen_Loop): Copy the bounds + on all paths. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/g-excact.ads + (Register_Global_Action): Refill comment. + (Name_To_Id): Change pragma Restriction from singular to plural. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_warn.adb (Check_References): Remove redundant guard, as it + is implied by a preceding call to Referenced_Check_Spec. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_warn.adb (Check_References): Remove useless query for "spec" + of a variable; refactor nested if-statements into a single + condition. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb + (In_Pragma_Expression): Add standard guard against searching too + far. + (In_Quantified_Expression): Likewise. + * sem_warn.adb + (May_Need_Initialized_Actual): Remove redundant parens. + (Check_References): Remove guard that duplicates a condition from + the enclosing if-statement; only assign E1T variable when + necessary. + (Within_Postcondition): Fix layout. + (No_Warn_On_In_Out): Balance parens in comment. + +2022-11-04 Steve Baird <baird@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Add the standard + '... "On" enables this extension.' sentence to the description of + static intrinsic functions. + * sem_ch13.adb + (Analyze_Aspect_Spec): In the call to Error_Msg_GNAT_Extension for + a Static aspect specification for an intrinsic function, specify + Is_Core_Extension => True. + * sem_eval.adb + (Eval_Intrinsic_Call): Test Core_Extensions_Allowed instead of + testing All_Extensions_Allowed. + * gnat_rm.texi: Regenerate. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * aspects.adb (Relocate_Aspect): Remove call to Set_Has_Aspects. + * sem_ch12.adb (Analyze_Formal_Package_Declaration): Likewise. + * sem_util.adb (Copy_Ghost_Aspect, Copy_SPARK_Mode_Aspect): + Likewise. + +2022-11-04 Javier Miranda <miranda@adacore.com> + + * exp_intr.adb + (Expand_Dispatching_Constructor_Call): Report an error on + unsupported dispatching constructor calls and report a warning on + calls that may fail at run time. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb + (Check_Components): Iterate using + First/Next_Component_Or_Discriminant. + (Has_Preelaborable_Initialization): Avoid repeated iteration with + calls to Check_Components with First_Entity and + First_Private_Entity. + (Is_Independent_Object_Entity): Tune indentation. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch7.adb (Clear_Constants): Only iterate from First_Entity + through Next_Entity; only examine variables because packages have + no assignable formal parameters. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Fix + typos. + * doc/gnat_ugn/elaboration_order_handling_in_gnat.rst: Fix typos + and refill as necessary; remove trailing whitespace. + * doc/gnat_ugn/gnat_and_program_execution.rst: Fix typos. + * gnat_ugn.texi: Regenerate. + +2022-11-04 Marc Poulhiès <poulhies@adacore.com> + + * sem_util.ads (Add_Block_Identifier): Add new extra Scope + argument. + * sem_util.adb (Add_Block_Identifier): Likewise and use this scope + variable instead of Current_Scope. + * exp_util.adb (Wrap_Statements_In_Block): Add new scope argument + to Add_Block_Identifier call. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Kill_Current_Values): Only iterate from + First_Entity through Next_Entity. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch6.adb (Controlling_Formal): Iterate with First/Next_Formal + and not with First/Next_Entity. + +2022-11-04 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb + (Expand_Interface_Conversion): Fix typo in comment. + +2022-11-04 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb + (Expand_Interface_Conversion): Under configurable runtime, when + the target type is an interface that is an ancestor of the operand + type, skip generating code to displace the pointer to reference + the target dispatch table. + * sem_disp.adb + (Propagate_Tag): Handle class-wide types when checking for the + addition of an implicit interface conversion. + +2022-11-04 Ronan Desplanques <desplanques@adacore.com> + + * doc/gnat_rm/standard_library_routines.rst: Fix typo. + * gnat_rm.texi: Regenerate. + +2022-11-04 Ghjuvan Lacambre <lacambre@adacore.com> + + * sa_messages.ads, sa_messages.adb: Remove files. + +2022-11-04 Ghjuvan Lacambre <lacambre@adacore.com> + + * checks.adb, exp_atag.adb, exp_attr.adb, exp_ch4.adb, exp_ch6.adb, + exp_ch7.adb, exp_dbug.adb, exp_disp.adb, exp_unst.adb, exp_util.adb, + freeze.adb, layout.adb, pprint.adb, rtsfind.adb, sem_aggr.adb, + sem_attr.adb, sem_case.adb, sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, + sem_ch5.adb, sem_ch6.adb, sem_ch8.adb, sem_dim.adb, sem_prag.adb, + sem_util.adb, sem_warn.adb: + Replace uses of `not Present (X)` with `No (X)`. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * einfo.ads: Fix typos in comments; refill as necessary. + * sinfo.ads: Likewise. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_rm/implementation_defined_aspects.rst: Fix typos. + * doc/gnat_rm/implementation_defined_attributes.rst: Likewise + * doc/gnat_rm/implementation_defined_characteristics.rst: Likewise + * doc/gnat_rm/implementation_defined_pragmas.rst: Likewise + * doc/gnat_rm/standard_library_routines.rst: Likewise. + * gnat_rm.texi: Regenerate. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch8.adb (Restore_Scope_Stack): Remove elements from the head + and not the tail of an element list. + +2022-11-04 Ronan Desplanques <desplanques@adacore.com> + + * sinfo.ads: Small editorial changes. + +2022-11-04 Steve Baird <baird@adacore.com> + + * opt.ads: Replace Ada_Version_Type enumeration literal + Ada_With_Extensions with two literals, Ada_With_Core_Extensions + and Ada_With_All_Extensions. Update uses of the deleted literal. + Replace Extensions_Allowed function with two functions: + All_Extensions_Allowed and Core_Extensions_Allowed. + * errout.ads, errout.adb: Add Boolean parameter to + Error_Msg_GNAT_Extension to indicate whether the construct in + question belongs to the curated subset. + * exp_ch5.adb, par-ch4.adb, sem_case.adb, sem_ch3.adb: + * sem_ch4.adb, sem_ch5.adb, sem_ch8.adb: Replace calls to + Extensions_Allowed with calls to Core_Extensions_Allowed for + constructs that are in the curated subset. + * sem_attr.adb, sem_ch13.adb, sem_eval.adb, sem_util.adb: Replace + calls to Extensions_Allowed with calls to All_Extensions_Allowed + for constructs that are not in the curated subset. + * par-ch3.adb: Override default for new parameter in calls to + Error_Msg_GNAT_Extension for constructs in the curated subset. + * par-prag.adb: Add Boolean parameter to Check_Arg_Is_On_Or_Off to + also allow ALL. Set Opt.Ada_Version appropriately for ALL or ON + arguments. + * sem_prag.adb: Allowed ALL argument for an Extensions_Allowed + pragma. Set Opt.Ada_Version appropriately for ALL or ON arguments. + * switch-c.adb: The -gnatX switch now enables only the curated + subset of language extensions (formerly it enabled all of them); + the new -gnatX0 switch enables all of them. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Document new "-gnatX0" switch and update documentation for + "-gnatX" switch. + * doc/gnat_rm/implementation_defined_pragmas.rst: Document new ALL + argument for pragma Extensions_Allowed and update documentation + for the ON argument. Delete mention of Ada 2022 Reduce attribute + as an extension. + * gnat_rm.texi, gnat_ugn.texi: Regenerate. + +2022-11-04 Steve Baird <baird@adacore.com> + + * bindgen.adb: Introduce two new string constants for the names of + the C-String variables that are assigned the names for adainit and + adafinal. Replace string literals in Gen_CUDA_Init with references + to these constants. In Gen_CUDA_Defs, generate C-String variable + declarations where these constants are the names of the variables. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch9.adb (Satisfies_Lock_Free_Requirements): Ignore + references to global variables inserted due to pragma + Initialize_Scalars. + +2022-11-04 Cedric Landet <landet@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Remove VxWorks + version 6. + * gnat_rm.texi, gnat_ugn.texi: Regenerate. + +2022-11-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch9.adb (Satisfies_Lock_Free_Requirements): Detect + references via expanded names. + +2022-11-04 Steve Baird <baird@adacore.com> + + * bindgen.adb + (Gen_CUDA_Init): Move existing loop body into a new local + procedure, Gen_CUDA_Register_Function_Call, and replace that loop + body with a call to this procedure. This first part is just + semantics-preserving refactoring. The second part is to add + Gen_CUDA_Register_Function_Call calls after the loop for the + device-side adainit and adafinal procedures. + 2022-10-11 Eric Botcazou <ebotcazou@adacore.com> * libgnat/system-linux-sparc.ads (Support_Atomic_Primitives): New diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 3471a81..81c9c28 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -373,7 +373,6 @@ package body Aspects is else Asps := New_List; Set_Aspect_Specifications (To, Asps); - Set_Has_Aspects (To); end if; -- Remove the aspect from its original owner and relocate it to node diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index f2aaa2d..4e89918 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -114,6 +114,11 @@ package body Bindgen is -- For CodePeer, introduce a wrapper subprogram which calls the -- user-defined main subprogram. + -- Names for local C-String variables + + Adainit_String_Obj_Name : constant String := "Adainit_Name_C_String"; + Adafinal_String_Obj_Name : constant String := "Adafinal_Name_C_String"; + -- Names and link_names for CUDA device adainit/adafinal procs. Device_Subp_Name_Prefix : constant String := "imported_device_"; @@ -131,9 +136,6 @@ package body Bindgen is function Device_Ada_Init_Subp_Name return String is (Device_Subp_Name_Prefix & Ada_Init_Name.all); - -- Text for aspect specifications (if any) given as part of the - -- Adainit and Adafinal spec declarations. - ---------------------------------- -- Interface_State Pragma Table -- ---------------------------------- @@ -1366,6 +1368,13 @@ package body Bindgen is WBI (" pragma Import (C, " & Device_Ada_Final_Subp_Name & ", Link_Name => """ & Device_Ada_Final_Link_Name & """);"); + -- C-string declarations for adainit and adafinal + WBI (" " & Adainit_String_Obj_Name + & " : Interfaces.C.Strings.Chars_Ptr;"); + WBI (" " & Adafinal_String_Obj_Name + & " : Interfaces.C.Strings.Chars_Ptr;"); + WBI (""); + WBI (""); end Gen_CUDA_Defs; @@ -1374,6 +1383,41 @@ package body Bindgen is ------------------- procedure Gen_CUDA_Init is + -- Generate call to register one function + procedure Gen_CUDA_Register_Function_Call + (Kernel_Name : String; + Kernel_String : String; + Kernel_Proc : String); + + ------------------------------------- + -- Gen_CUDA_Register_Function_Call -- + ------------------------------------- + + procedure Gen_CUDA_Register_Function_Call + (Kernel_Name : String; + Kernel_String : String; + Kernel_Proc : String) is + begin + WBI (" " & Kernel_String & " :="); + WBI (" Interfaces.C.Strings.New_Char_Array (""" + & Kernel_Name + & """);"); + + -- Generate call to CUDA runtime to register function. + WBI (" CUDA_Register_Function ("); + WBI (" Fat_Binary_Handle, "); + WBI (" " & Kernel_Proc & "'Address,"); + WBI (" " & Kernel_String & ","); + WBI (" " & Kernel_String & ","); + WBI (" -1,"); + WBI (" System.Null_Address,"); + WBI (" System.Null_Address,"); + WBI (" System.Null_Address,"); + WBI (" System.Null_Address,"); + WBI (" System.Null_Address);"); + WBI (""); + end Gen_CUDA_Register_Function_Call; + begin if not Enable_CUDA_Expansion then return; @@ -1404,26 +1448,23 @@ package body Bindgen is Get_Name_String (CUDA_Kernels.Table (K).Kernel_Name); -- Kernel_Name is the name of the kernel, after package expansion. begin - WBI (" " & Kernel_String & " :="); - WBI (" Interfaces.C.Strings.New_Char_Array (""" - & Kernel_Name - & """);"); - -- Generate call to CUDA runtime to register function. - WBI (" CUDA_Register_Function ("); - WBI (" Fat_Binary_Handle, "); - WBI (" " & Kernel_Proc & "'Address,"); - WBI (" " & Kernel_String & ","); - WBI (" " & Kernel_String & ","); - WBI (" -1,"); - WBI (" System.Null_Address,"); - WBI (" System.Null_Address,"); - WBI (" System.Null_Address,"); - WBI (" System.Null_Address,"); - WBI (" System.Null_Address);"); - WBI (""); + Gen_CUDA_Register_Function_Call + (Kernel_Name => Kernel_Name, + Kernel_String => Kernel_String, + Kernel_Proc => Kernel_Proc); end; end loop; + -- Register device-side Adainit and Adafinal + Gen_CUDA_Register_Function_Call + (Kernel_Name => Device_Ada_Init_Link_Name, + Kernel_String => Adainit_String_Obj_Name, + Kernel_Proc => Device_Ada_Init_Subp_Name); + Gen_CUDA_Register_Function_Call + (Kernel_Name => Device_Ada_Final_Link_Name, + Kernel_String => Adafinal_String_Obj_Name, + Kernel_Proc => Device_Ada_Final_Subp_Name); + WBI (" CUDA_Register_Fat_Binary_End (Fat_Binary_Handle);"); -- perform device (as opposed to host) elaboration diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8fa16b8..4741294 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -593,7 +593,7 @@ package body Checks is pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N)); if Ada_Version >= Ada_2012 - and then not Present (Param_Ent) + and then No (Param_Ent) and then Is_Entity_Name (N) and then Ekind (Entity (N)) in E_Constant | E_Variable and then Present (Effective_Extra_Accessibility (Entity (N))) @@ -778,7 +778,7 @@ package body Checks is -- Note: Expr is empty if the address-clause is applied to in-mode -- actuals (allowed by 13.1(22)). - if not Present (Expr) + if No (Expr) or else (Is_Entity_Name (Expression (AC)) and then Ekind (Entity (Expression (AC))) = E_Constant diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst index 4541f2b..960c505 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst @@ -422,7 +422,7 @@ This aspect is equivalent to :ref:`attribute Object_Size<Attribute-Object_Size>` Aspect Obsolescent ================== -.. index:: Obsolsecent +.. index:: Obsolescent This aspect is equivalent to :ref:`pragma Obsolescent<Pragma_Obsolescent>`. Note that the evaluation of this aspect happens at the point of occurrence, it is not diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index d839b1f..22dae06 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -589,7 +589,7 @@ Attribute Library_Level ``P'Library_Level``, where P is an entity name, returns a Boolean value which is True if the entity is declared at the library level, and False otherwise. Note that within a -generic instantition, the name of the generic unit denotes the +generic instantiation, the name of the generic unit denotes the instance, which means that this attribute can be used to test if a generic is instantiated at the library level, as shown in this example: @@ -1231,7 +1231,7 @@ Attribute System_Allocator_Alignment .. index:: System_Allocator_Alignment ``Standard'System_Allocator_Alignment`` (``Standard`` is the only -allowed prefix) provides the observable guaranted to be honored by +allowed prefix) provides the observable guaranteed to be honored by the system allocator (malloc). This is a static value that can be used in user storage pools based on malloc either to reject allocation with alignment too large or to enable a realignment circuitry if the diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst index 095d04b..fb6a63c 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst @@ -1215,7 +1215,7 @@ a distributed application. * "The range of type System.RPC.Partition_Id. See E.5(14)." -System.RPC.Partion_ID'Last is Integer'Last. See source file :file:`s-rpc.ads`. +System.RPC.Partition_ID'Last is Integer'Last. See source file :file:`s-rpc.ads`. * "Implementation-defined interfaces in the PCS. See E.5(26)." diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 6752d48..7e5fb70 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -1389,7 +1389,7 @@ Pragma CPP_Virtual This pragma is now obsolete and, other than generating a warning if warnings on obsolescent features are enabled, is completely ignored. It is retained for compatibility -purposes. It used to be required to ensure compoatibility with C++, but +purposes. It used to be required to ensure compatibility with C++, but is no longer required for that purpose because GNAT generates the same object layout as the G++ compiler by default. @@ -2174,16 +2174,19 @@ Syntax: .. code-block:: ada - pragma Extensions_Allowed (On | Off); + pragma Extensions_Allowed (On | Off | All); -This configuration pragma enables or disables the implementation -extension mode (the use of Off as a parameter cancels the effect -of the *-gnatX* command switch). +This configuration pragma enables (via the "On" or "All" argument) or disables +(via the "Off" argument) the implementation extension mode; the pragma takes +precedence over the *-gnatX* and *-gnatX0* command switches. -In extension mode, the latest version of the Ada language is -implemented (currently Ada 2022), and in addition a number -of GNAT specific extensions are recognized as follows: +If an argument of "All" is specified, the latest version of the Ada language +is implemented (currently Ada 2022) and, in addition, a number +of GNAT specific extensions are recognized. These extensions are listed +below. An argument of "On" has the same effect except that only +some, not all, of the listed extensions are enabled; those extensions +are identified below. * Constrained attribute for generic objects @@ -2197,10 +2200,7 @@ of GNAT specific extensions are recognized as follows: functions and the compiler will evaluate some of these intrinsic statically, in particular the ``Shift_Left`` and ``Shift_Right`` intrinsics. -* ``'Reduce`` attribute - - This attribute part of the Ada 202x language definition is provided for - now under -gnatX to confirm and potentially refine its usage and syntax. + An Extensions_Allowed pragma argument of "On" enables this extension. * ``[]`` aggregates @@ -2334,6 +2334,8 @@ of GNAT specific extensions are recognized as follows: for a given identifer must all statically match. Currently, the case of a binding for a nondiscrete component is not implemented. + An Extensions_Allowed pragma argument of "On" enables this extension. + * Fixed lower bounds for array types and subtypes Unconstrained array types and subtypes can be specified with a lower bound @@ -2378,6 +2380,8 @@ of GNAT specific extensions are recognized as follows: knows the lower bound of unconstrained array formals when the formal's subtype has index ranges with static fixed lower bounds. + An Extensions_Allowed pragma argument of "On" enables this extension. + * Prefixed-view notation for calls to primitive subprograms of untagged types Since Ada 2005, calls to primitive subprograms of a tagged type that @@ -2395,6 +2399,8 @@ of GNAT specific extensions are recognized as follows: name, preference is given to the component in a selected_component (as is currently the case for tagged types with such component names). + An Extensions_Allowed pragma argument of "On" enables this extension. + * Expression defaults for generic formal functions The declaration of a generic formal function is allowed to specify @@ -3866,7 +3872,7 @@ decrease or increase in successive iterations of the loop. In its simplest form, just one expression is specified, whose value must increase or decrease on each iteration of the loop. -In a more complex form, multiple arguments can be given which are intepreted +In a more complex form, multiple arguments can be given which are interpreted in a nesting lexicographic manner. For example: .. code-block:: ada @@ -4947,7 +4953,7 @@ appear at the start of the declarations in a subprogram body Note: This pragma is called ``Post_Class`` rather than ``Post'Class`` because the latter would not be strictly conforming to the allowed syntax for pragmas. The motivation -for provinding pragmas equivalent to the aspects is to allow a program +for providing pragmas equivalent to the aspects is to allow a program to be written using the pragmas, and then compiled if necessary using an Ada compiler that does not recognize the pragmas or aspects, but is prepared to ignore the pragmas. The assertion @@ -6213,7 +6219,7 @@ replacement of any dots in the unit name by the specified string literal. Note that Source_File_Name pragmas should not be used if you are using project files. The reason for this rule is that the project manager is not -aware of these pragmas, and so other tools that use the projet file would not +aware of these pragmas, and so other tools that use the project file would not be aware of the intended naming conventions. If you are using project files, file naming is controlled by Source_File_Name_Project pragmas, which are usually supplied automatically by the project manager. A pragma @@ -6869,7 +6875,7 @@ Syntax: This pragma specifies that the specified entity, which must be a variable declared in a library-level package, is to be marked as "Thread Local Storage" (``TLS``). On systems supporting this (which -include Windows, Solaris, GNU/Linux, and VxWorks 6), this causes each +include Windows, Solaris, GNU/Linux, and VxWorks), this causes each thread (and hence each Ada task) to see a distinct copy of the variable. The variable must not have default initialization, and if there is @@ -7287,7 +7293,7 @@ configuration pragma will ensure this test is not suppressed: This pragma is standard in Ada 2005. It is available in all earlier versions of Ada as an implementation-defined pragma. -Note that in addition to the checks defined in the Ada RM, GNAT recogizes a +Note that in addition to the checks defined in the Ada RM, GNAT recognizes a number of implementation-defined check names. See the description of pragma ``Suppress`` for full details. @@ -7588,7 +7594,7 @@ expression (which does not exist in Ada 83). Note if the second argument of ``DETAILS`` is a ``local_NAME`` then the second form is always understood. If the intention is to use the fourth form, then you can write ``NAME & ""`` to force the -intepretation as a *static_string_EXPRESSION*. +interpretation as a *static_string_EXPRESSION*. Note: if the first argument is a valid ``TOOL_NAME``, it will be interpreted that way. The use of the ``TOOL_NAME`` argument is relevant only to users diff --git a/gcc/ada/doc/gnat_rm/standard_library_routines.rst b/gcc/ada/doc/gnat_rm/standard_library_routines.rst index 398b613..27659a4 100644 --- a/gcc/ada/doc/gnat_rm/standard_library_routines.rst +++ b/gcc/ada/doc/gnat_rm/standard_library_routines.rst @@ -157,7 +157,7 @@ the unit is not implemented. ``Ada.Directories.Hierarchical_File_Names`` *(A.16.1)* This package provides additional directory operations handling - hiearchical file names. + hierarchical file names. ``Ada.Directories.Information`` *(A.16)* @@ -550,7 +550,7 @@ the unit is not implemented. This package provides the capability of associating arbitrary task-specific data with separate tasks. -``Ada.Task_Identifification`` *(C.7.1)* +``Ada.Task_Identification`` *(C.7.1)* This package provides capabilities for task identification. ``Ada.Task_Termination`` *(C.7.3)* diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index d4bddff..83bc50f 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -2180,7 +2180,13 @@ Alphabetical List of All Switches .. index:: -gnatX (gcc) :switch:`-gnatX` - Enable GNAT implementation extensions and latest Ada version. + Enable core GNAT implementation extensions and latest Ada version. + + +.. index:: -gnatX0 (gcc) + +:switch:`-gnatX0` + Enable all GNAT implementation extensions and latest Ada version. .. index:: -gnaty (gcc) @@ -5585,16 +5591,27 @@ indicate Ada 83 compatibility mode. language. -.. index:: -gnatX (gcc) +.. index:: -gnatX0 (gcc) .. index:: Ada language extensions .. index:: GNAT extensions -:switch:`-gnatX` (Enable GNAT Extensions) +:switch:`-gnatX0` (Enable GNAT Extensions) This switch directs the compiler to implement the latest version of the language (currently Ada 2022) and also to enable certain GNAT implementation extensions that are not part of any Ada standard. For a full list of these extensions, see the GNAT reference manual, ``Pragma Extensions_Allowed``. +.. index:: -gnatX (gcc) +.. index:: Ada language extensions +.. index:: GNAT extensions + +:switch:`-gnatX` (Enable core GNAT Extensions) + This switch is similar to -gnatX0 except that only some, not all, of the + GNAT-defined language extensions are enabled. For a list of the + extensions enabled by this switch, see the GNAT reference manual + ``Pragma Extensions_Allowed`` and the description of that pragma's + "On" (as opposed to "All") argument. + .. _Character_Set_Control: @@ -7386,7 +7403,7 @@ development environments much more flexible. Examples of ``gnatbind`` Usage ------------------------------ -Here are some examples of ``gnatbind`` invovations: +Here are some examples of ``gnatbind`` invocations: :: diff --git a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst index 4982ebf..76a1461 100644 --- a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst @@ -265,7 +265,7 @@ respect to control and data flow. Checking the Elaboration Order ============================== -To avoid placing the entire elaboration-order burden on the programmer, Ada +To avoid placing the entire elaboration-order burden on the programmer, Ada provides three lines of defense: * *Static semantics* @@ -931,9 +931,9 @@ Resolving Elaboration Circularities =================================== The most desirable option from the point of view of long-term maintenance is to -rearrange the program so that the elaboration problems are avoided. One useful -technique is to place the elaboration code into separate child packages. -Another is to move some of the initialization code to explicitly invoked +rearrange the program so that the elaboration problems are avoided. One useful +technique is to place the elaboration code into separate child packages. +Another is to move some of the initialization code to explicitly invoked subprograms, where the program controls the order of initialization explicitly. Although this is the most desirable option, it may be impractical and involve too much modification, especially in the case of complex legacy code. @@ -990,8 +990,9 @@ following tactics to eliminate the circularity: change pragma Elaborate_All for unit "..." to Elaborate in unit "..." This tactic is always suggested with the pragma ``Elaborate_All`` elimination - tactic. It offers a different alernative of guaranteeing that the argument of - the pragma will still be elaborated prior to the unit containing the pragma. + tactic. It offers a different alternative of guaranteeing that the argument + of the pragma will still be elaborated prior to the unit containing the + pragma. The programmer should update the pragma as advised, and rebuild the program. @@ -1281,7 +1282,7 @@ Summary of Procedures for Elaboration Control A programmer should first compile the program with the default options, using none of the binder or compiler switches. If the binder succeeds in finding an -elaboration order, then apart from possible cases involing dispatching calls +elaboration order, then apart from possible cases involving dispatching calls and access-to-subprogram types, the program is free of elaboration errors. If it is important for the program to be portable to compilers other than GNAT, diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index 0d78e43..e827d1f 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -2321,7 +2321,7 @@ erroneous, and the compiler would be entitled to assume that However, in practice, this would cause some existing code that seems to work with no optimization to start failing at high -levels of optimzization. +levels of optimization. What the compiler does for such cases is to assume that marking a variable as aliased indicates that some "funny business" may @@ -2728,7 +2728,7 @@ To deal with the portability issue, and with the problem of mathematical versus run-time interpretation of the expressions in assertions, GNAT provides comprehensive control over the handling of intermediate overflow. GNAT can operate in three modes, and -furthemore, permits separate selection of operating modes for +furthermore, permits separate selection of operating modes for the expressions within assertions (here the term 'assertions' is used in the technical sense, which includes preconditions and so forth) and for expressions appearing outside assertions. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e350f13..2a1a406 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -874,7 +874,7 @@ package Einfo is -- are generated (subprograms, package declarations and package -- bodies). Defined if there are pending generic body instantiations -- for the corresponding entity. If this flag is set, then generation --- of the subprogram descriptor for the corresponding enities must +-- of the subprogram descriptor for the corresponding entities must -- be delayed, since the insertion of the generic body may add entries -- to the list of handlers. -- @@ -2570,7 +2570,7 @@ package Einfo is -- Is_Elaboration_Checks_OK_Id -- Defined in elaboration targets (see terminology in Sem_Elab). Set when --- the target appears in a region which is subject to elabled elaboration +-- the target appears in a region which is subject to enabled elaboration -- checks. Such targets are allowed to generate run-time conditional ABE -- checks or guaranteed ABE failures. @@ -3114,7 +3114,7 @@ package Einfo is -- Defined in all entities, set in E_Package and E_Generic_Package -- entities to which a pragma Preelaborate is applied, and also in -- all entities within such packages. Note that the fact that this --- flag is set does not necesarily mean that no elaboration code is +-- flag is set does not necessarily mean that no elaboration code is -- generated for the package. -- Is_Primitive @@ -3228,7 +3228,7 @@ package Einfo is -- Defined in all entities, set only for a variable or constant for -- which the Renamed_Object field is non-empty and for which the -- renaming is handled by the front end, by macro substitution of --- a copy of the (evaluated) name tree whereever the variable is used. +-- a copy of the (evaluated) name tree wherever the variable is used. -- Is_Return_Object -- Defined in all object entities. True if the object is the return @@ -3964,7 +3964,8 @@ package Einfo is -- Present in variable entities. Contains all references to the variable -- when it is subject to pragma Part_Of. If the variable is a constituent -- of a single protected/task type, the references are examined as they --- must appear only within the type defintion and the corresponding body. +-- must appear only within the type definition and the corresponding +-- body. -- Partial_DIC_Procedure (synthesized) -- Defined in type entities. Set for a private type and its full view @@ -4058,7 +4059,7 @@ package Einfo is -- Prev_Entity -- Defined in all entities. The entities of a scope are chained, and this --- field is used as a backward pointer for this entity list - effectivly +-- field is used as a backward pointer for this entity list - effectively -- making the entity chain doubly-linked. -- Primitive_Operations (synthesized) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 79e162a..5730a54 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -881,18 +881,40 @@ package body Errout is -- Error_Msg_GNAT_Extension -- ------------------------------ - procedure Error_Msg_GNAT_Extension (Extension : String; Loc : Source_Ptr) is + procedure Error_Msg_GNAT_Extension + (Extension : String; + Loc : Source_Ptr; + Is_Core_Extension : Boolean := False) + is begin - if not Extensions_Allowed then - Error_Msg (Extension & " is a 'G'N'A'T-specific extension", Loc); + if (if Is_Core_Extension + then Core_Extensions_Allowed + else All_Extensions_Allowed) + then + return; + end if; - if No (Ada_Version_Pragma) then - Error_Msg ("\unit must be compiled with -gnatX " - & "or use pragma Extensions_Allowed (On)", Loc); + Error_Msg (Extension & " is a 'G'N'A'T-specific extension", Loc); + + if No (Ada_Version_Pragma) then + if Is_Core_Extension then + Error_Msg + ("\unit must be compiled with -gnatX '[or -gnatX0'] " & + "or use pragma Extensions_Allowed (On) '[or All']", Loc); else - Error_Msg_Sloc := Sloc (Ada_Version_Pragma); - Error_Msg ("\incompatible with Ada version set#", Loc); - Error_Msg ("\must use pragma Extensions_Allowed (On)", Loc); + Error_Msg + ("\unit must be compiled with -gnatX0 " & + "or use pragma Extensions_Allowed (All)", Loc); + end if; + else + Error_Msg_Sloc := Sloc (Ada_Version_Pragma); + Error_Msg ("\incompatible with Ada version set#", Loc); + if Is_Core_Extension then + Error_Msg + ("\must use pragma Extensions_Allowed (On) '[or All']", Loc); + else + Error_Msg + ("\must use pragma Extensions_Allowed (All)", Loc); end if; end if; end Error_Msg_GNAT_Extension; @@ -3361,23 +3383,13 @@ package body Errout is E := Errors.Table (E).Next; end loop; + -- Warnings may have been posted on subexpressions of original tree + if Nkind (N) = N_Raise_Constraint_Error and then Is_Rewrite_Substitution (N) and then No (Condition (N)) then - -- Warnings may have been posted on subexpressions of the original - -- tree. We place the original node back on the tree to remove - -- those warnings, whose sloc do not match those of any node in - -- the current tree. Given that we are in unreachable code, this - -- modification to the tree is harmless. - - if Is_List_Member (N) then - Set_Condition (N, Original_Node (N)); - Check_All_Warnings (Condition (N)); - else - Rewrite (N, Original_Node (N)); - Check_All_Warnings (N); - end if; + Check_All_Warnings (Original_Node (N)); end if; return OK; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 45166f5..78fe514 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -937,11 +937,18 @@ package Errout is procedure Error_Msg_Ada_2022_Feature (Feature : String; Loc : Source_Ptr); -- Analogous to Error_Msg_Ada_2012_Feature, for Ada 2022 - procedure Error_Msg_GNAT_Extension (Extension : String; Loc : Source_Ptr); - -- If not operating with extensions allowed, posts errors complaining - -- that Extension is only supported when the -gnatX switch is enabled - -- or pragma Extensions_Allowed (On) is used. Loc indicates the source - -- location of the extension construct. + procedure Error_Msg_GNAT_Extension + (Extension : String; + Loc : Source_Ptr; + Is_Core_Extension : Boolean := False); + -- To be called as part of checking a GNAT language extension (either a + -- core extension or not, as indicated by the Is_Core_Extension parameter). + -- If switch -gnatX0 or pragma Extension_Allowed (All) is in effect, then + -- either kind of extension is allowed; if switch -gnatX or pragma + -- Extensions_Allowed (On) is in effect, then only core extensions are + -- allowed. Otherwise, no extensions are allowed. A disallowed construct + -- is flagged as an error. Loc indicates the source location of the + -- extension construct. procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg; -- Debugging routine to dump an error message diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 1857055..dde49d1 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2058,7 +2058,7 @@ package body Exp_Aggr is -- to do that if we already have the base type at hand. if Etype (L) = Index_Base then - L_L := L; + L_L := New_Copy_Tree (L); else L_L := Make_Qualified_Expression (Loc, @@ -2067,7 +2067,7 @@ package body Exp_Aggr is end if; if Etype (H) = Index_Base then - L_H := H; + L_H := New_Copy_Tree (H); else L_H := Make_Qualified_Expression (Loc, diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index 7871363..074ab4e 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -312,7 +312,7 @@ package body Exp_Atag is if not Is_Predefined_Dispatching_Operation (Prim) and then not Is_Predefined_Dispatching_Operation (E) - and then not Present (Interface_Alias (Prim)) + and then No (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (E) and then not Is_Eliminated (E) and then Prim_Pos <= CPP_Nb_Prims diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 0e79b5d..1ef3065 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1998,16 +1998,22 @@ package body Exp_Attr is -- Start of processing for Expand_N_Attribute_Reference begin - -- Do required validity checking, if enabled. Do not apply check to - -- output parameters of an Asm instruction, since the value of this - -- is not set till after the attribute has been elaborated, and do - -- not apply the check to the arguments of a 'Read or 'Input attribute - -- reference since the scalar argument is an OUT scalar. + -- Do required validity checking, if enabled. + -- + -- Skip check for output parameters of an Asm instruction (since their + -- valuesare not set till after the attribute has been elaborated), + -- for the arguments of a 'Read or 'Input attribute reference (since + -- the scalar argument is an OUT scalar) and for the arguments of a + -- 'Has_Same_Storage or 'Overlaps_Storage attribute reference (which not + -- considered to be reads of their prefixes and expressions, see Ada RM + -- 13.3(73.10/3)). if Validity_Checks_On and then Validity_Check_Operands and then Id /= Attribute_Asm_Output and then Id /= Attribute_Read and then Id /= Attribute_Input + and then Id /= Attribute_Has_Same_Storage + and then Id /= Attribute_Overlaps_Storage then declare Expr : Node_Id; @@ -6575,7 +6581,7 @@ package body Exp_Attr is -- If Storage_Size wasn't found (can only occur in the simple -- storage pool case), then simply use zero for the result. - if not Present (Alloc_Op) then + if No (Alloc_Op) then Rewrite (N, Make_Integer_Literal (Loc, 0)); -- Otherwise, rewrite the allocator as a call to pool type's diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0b7e391..7a3a414 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6733,7 +6733,7 @@ package body Exp_Ch4 is -- Skip this for predicated types, where such expressions are a -- reasonable way of testing if something meets the predicate. - and then not Present (Predicate_Function (Ltyp)) + and then No (Predicate_Function (Ltyp)) then Substitute_Valid_Check; return; @@ -7148,7 +7148,7 @@ package body Exp_Ch4 is if Is_Entity_Name (Lop) then Expr_Entity := Param_Entity (Lop); - if not Present (Expr_Entity) then + if No (Expr_Entity) then Expr_Entity := Entity (Lop); end if; end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index d5d66d9..1dbbff9 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3939,7 +3939,9 @@ package body Exp_Ch5 is -- Start of processing for Expand_N_Case_Statement begin - if Extensions_Allowed and then not Is_Discrete_Type (Etype (Expr)) then + if Core_Extensions_Allowed + and then not Is_Discrete_Type (Etype (Expr)) + then Rewrite (N, Expand_General_Case_Statement); Analyze (N); return; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index ce1a752..cf64e82 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -376,7 +376,7 @@ package body Exp_Ch6 is -- If no return object is provided, then pass null - if not Present (Return_Object) then + if No (Return_Object) then Obj_Address := Make_Null (Loc); Set_Parent (Obj_Address, Function_Call); @@ -3223,7 +3223,7 @@ package body Exp_Ch6 is loop Aspect_Bearer := Nearest_Ancestor (Aspect_Bearer); - if not Present (Aspect_Bearer) then + if No (Aspect_Bearer) then return False; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index fc4516d..b20d7db 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4452,7 +4452,7 @@ package body Exp_Ch7 is begin if Is_Derived_Type (Typ) and then Comes_From_Source (E) - and then not Present (Overridden_Operation (E)) + and then No (Overridden_Operation (E)) then -- We know that the explicit operation on the type does not override -- the inherited operation of the parent, and that the derivation diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 76f08e3..3ab6888 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -415,7 +415,7 @@ package body Exp_Dbug is | N_Identifier => if No (Entity (Ren)) - or else not Present (Renamed_Entity_Or_Object (Entity (Ren))) + or else No (Renamed_Entity_Or_Object (Entity (Ren))) then exit; end if; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 3ac4b3b..41da7a2 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1304,17 +1304,24 @@ package body Exp_Disp is and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True) then return; - end if; - -- When the type of the operand and the target interface type match, - -- it is generally safe to skip generating code to displace the - -- pointer to the object to reference the secondary dispatch table - -- associated with the target interface type. The exception to this - -- general rule is when the underlying object of the type conversion - -- is an object built by means of a dispatching constructor (since in - -- such case the expansion of the constructor call is a direct call - -- to an object primitive, i.e. without thunks, and the expansion of - -- the constructor call adds an explicit conversion to the target + -- When the target type is an interface type that is an ancestor of + -- the operand type, it is generally safe to skip generating code to + -- displace the pointer to the object to reference the secondary + -- dispatch table of the target interface type. Two scenarios are + -- possible here: + -- 1) The operand type is a regular tagged type + -- 2) The operand type is an interface type + -- In the former case the target interface and the regular tagged + -- type share the primary dispatch table of the object; in the latter + -- case the operand interface has all the primitives of the ancestor + -- interface type (and exactly in the same dispatch table slots). + -- + -- The exception to this general rule is when the underlying object + -- is built by means of a dispatching constructor (since in such case + -- the expansion of the constructor call is a direct call to an + -- object primitive, i.e. without thunks, and the expansion of + -- the constructor call adds this explicit conversion to the target -- interface type to force the displacement of the pointer to the -- object to reference the corresponding secondary dispatch table -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)). @@ -1326,7 +1333,10 @@ package body Exp_Disp is -- to the object, because generic dispatching constructors are not -- supported. - if Opnd = Iface_Typ and then not RTE_Available (RE_Displace) then + elsif Is_Interface (Iface_Typ) + and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True) + and then not RTE_Available (RE_Displace) + then return; end if; end; @@ -4052,8 +4062,7 @@ package body Exp_Disp is and then not Is_Abstract_Subprogram (Prim) and then not Is_Eliminated (Prim) and then not Generate_SCIL - and then not - Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) + and then No (Prim_Table (UI_To_Int (DT_Position (Prim)))) then if not Build_Thunks then E := Ultimate_Alias (Prim); @@ -5269,7 +5278,7 @@ package body Exp_Disp is E : Entity_Id; begin - if not Present (Def) + if No (Def) or else Entity (Name (Def)) /= First_Subtype (Typ) then New_Node := @@ -5872,8 +5881,7 @@ package body Exp_Disp is and then not Is_Abstract_Subprogram (Prim) and then not Is_Eliminated (Prim) and then not Generate_SCIL - and then not Present (Prim_Table - (UI_To_Int (DT_Position (Prim)))) + and then No (Prim_Table (UI_To_Int (DT_Position (Prim)))) then E := Ultimate_Alias (Prim); pragma Assert (not Is_Abstract_Subprogram (E)); @@ -6038,7 +6046,7 @@ package body Exp_Disp is -- those are only required to build secondary dispatch -- tables. - and then not Present (Interface_Alias (Prim)) + and then No (Interface_Alias (Prim)) -- Skip abstract and eliminated primitives @@ -7496,7 +7504,7 @@ package body Exp_Disp is -- Primitive associated with a tagged type - if not Present (Interface_Alias (Prim)) then + if No (Interface_Alias (Prim)) then Tag_Typ := Scope (DTC_Entity (Prim)); Pos := DT_Position (Prim); Tag := First_Tag_Component (Tag_Typ); @@ -8023,7 +8031,7 @@ package body Exp_Disp is -- same dispatch table slot, but if it renames an operation in a -- nested package it's a new primitive and will have its own slot. - elsif not Present (Interface_Alias (Prim)) + elsif No (Interface_Alias (Prim)) and then Present (Alias (Prim)) and then Chars (Prim) = Chars (Alias (Prim)) and then Nkind (Unit_Declaration_Node (Prim)) /= @@ -8191,7 +8199,7 @@ package body Exp_Disp is and then Present (Alias (Prim)) and then not Is_Interface (Find_Dispatching_Type (Ultimate_Alias (Prim))) - and then not Present (Interface_Alias (Prim)) + and then No (Interface_Alias (Prim)) and then Is_Derived_Type (Typ) and then In_Private_Part (Current_Scope) and then diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index bd987f0..cb9b5be 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -24,13 +24,16 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Aspects; use Aspects; with Checks; use Checks; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; +with Errout; use Errout; with Expander; use Expander; with Exp_Atag; use Exp_Atag; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; with Exp_Code; use Exp_Code; @@ -277,6 +280,47 @@ package body Exp_Intr is Result_Typ : Entity_Id; begin + pragma Assert (Is_Class_Wide_Type (Etype (Entity (Name (N))))); + + -- Report case where we know that the generated code is wrong; that + -- is a dispatching constructor call whose controlling type has tasks + -- but its root type does not have tasks. In such case the constructor + -- subprogram of the root type does not have extra formals but the + -- constructor of the derivation must have extra formals. + + if not Global_No_Tasking + and then not No_Run_Time_Mode + and then Is_Build_In_Place_Function (Entity (Name (N))) + and then not Has_Task (Root_Type (Etype (Entity (Name (N))))) + and then not Has_Aspect (Root_Type (Etype (Entity (Name (N)))), + Aspect_No_Task_Parts) + then + -- Case 1: Explicit tag reference (which allows static check) + + if Nkind (Tag_Arg) = N_Identifier + and then Present (Entity (Tag_Arg)) + and then Is_Tag (Entity (Tag_Arg)) + then + if Has_Task (Related_Type (Entity (Tag_Arg))) then + Error_Msg_N ("unsupported dispatching constructor call", N); + Error_Msg_NE + ("\work around this problem by defining task component " + & "type& using access-to-task-type", + N, Related_Type (Entity (Tag_Arg))); + end if; + + -- Case 2: Dynamic tag which may fail at run time + + else + Error_Msg_N + ("unsupported dispatching constructor call if the type " + & "of the built object has task components??", N); + Error_Msg_N + ("\work around this problem by replacing task components " + & "with access-to-task-type components??", N); + end if; + end if; + -- Remove side effects from tag argument early, before rewriting -- the dispatching constructor call, as Remove_Side_Effects relies -- on Tag_Arg's Parent link properly attached to the tree (once the diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 9164644..fd4c543 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -2225,7 +2225,7 @@ package body Exp_Unst is if No (UPJ.Ref) or else not Is_Entity_Name (UPJ.Ref) - or else not Present (Entity (UPJ.Ref)) + or else No (Entity (UPJ.Ref)) or else not Opt.Generate_C_Code then goto Continue; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f569d2e..3566702 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1700,7 +1700,7 @@ package body Exp_Util is -- type attributes. begin - if not Present (Priv_Typ) and then not Present (Full_Typ) then + if No (Priv_Typ) and then No (Full_Typ) then return; end if; @@ -1787,7 +1787,7 @@ package body Exp_Util is -- full type doesn't have its own DIC, but is inherited from -- a type with DIC), get the full DIC procedure. - if not Present (Par_Proc) then + if No (Par_Proc) then Par_Proc := DIC_Procedure (Par_Typ); end if; @@ -2745,7 +2745,7 @@ package body Exp_Util is -- type attributes. begin - if not Present (Priv_Typ) and then not Present (Full_Typ) then + if No (Priv_Typ) and then No (Full_Typ) then return; end if; @@ -3072,7 +3072,7 @@ package body Exp_Util is Prag_Typ_Arg : Node_Id; begin - if not Present (T) then + if No (T) then return; end if; @@ -11367,7 +11367,7 @@ package body Exp_Util is -- Create a label for the block in case the block needs to manage the -- secondary stack. A label allows for flag Uses_Sec_Stack to be set. - Add_Block_Identifier (Block_Nod, Block_Id); + Add_Block_Identifier (Block_Nod, Block_Id, Scop); -- When wrapping the statements of an iterator loop, check whether -- the loop requires secondary stack management and if so, propagate diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 346904e..888e2ec 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3793,7 +3793,7 @@ package body Freeze is -- Set component size if not already set by a component -- size clause. - if not Present (Comp_Size_C) then + if No (Comp_Size_C) then Set_Component_Size (Arr, Csiz); end if; @@ -3805,7 +3805,7 @@ package body Freeze is -- explicitly, then generate a warning. if Has_Pragma_Pack (Arr) - and then not Present (Comp_Size_C) + and then No (Comp_Size_C) and then (Csiz = 7 or else Csiz = 15 or else Csiz = 31) and then Known_Esize (Base_Type (Ctyp)) and then Esize (Base_Type (Ctyp)) = Csiz + 1 @@ -7059,7 +7059,7 @@ package body Freeze is -- end of a declarative part. if Is_Library_Level_Tagged_Type (E) - and then not Present (Full_View (E)) + and then No (Full_View (E)) then Set_Is_Frozen (E, False); goto Leave; @@ -7467,7 +7467,7 @@ package body Freeze is -- If no formal is passed in, then issue an error for a -- missing formal. - elsif not Present (Pool_Op_Formal) then + elsif No (Pool_Op_Formal) then Error_Msg_NE ("simple storage pool op missing formal " & Formal_Name & " of type&", Pool_Op, Expected_Type); @@ -7599,7 +7599,7 @@ package body Freeze is -- and no excess formals are present, then this -- operation has been validated, so record it. - if not Present (Formal) and then Is_OK then + if No (Formal) and then Is_OK then Found_Op := Op; end if; end if; @@ -7611,7 +7611,7 @@ package body Freeze is -- so issue an error if none was found. if Op_Name = Name_Allocate - and then not Present (Found_Op) + and then No (Found_Op) then Error_Msg_N ("missing % operation for simple " & "storage pool type", Pool_Type); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index e79cdee..fbd8bb8 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Oct 04, 2022 +GNAT Reference Manual , Oct 27, 2022 AdaCore @@ -2787,7 +2787,7 @@ that is, they never return an object whose type is a descendant of type T. This pragma is now obsolete and, other than generating a warning if warnings on obsolescent features are enabled, is completely ignored. It is retained for compatibility -purposes. It used to be required to ensure compoatibility with C++, but +purposes. It used to be required to ensure compatibility with C++, but is no longer required for that purpose because GNAT generates the same object layout as the G++ compiler by default. @@ -3608,16 +3608,19 @@ GNAT User’s Guide. Syntax: @example -pragma Extensions_Allowed (On | Off); +pragma Extensions_Allowed (On | Off | All); @end example -This configuration pragma enables or disables the implementation -extension mode (the use of Off as a parameter cancels the effect -of the `-gnatX' command switch). +This configuration pragma enables (via the “On” or “All” argument) or disables +(via the “Off” argument) the implementation extension mode; the pragma takes +precedence over the `-gnatX' and `-gnatX0' command switches. -In extension mode, the latest version of the Ada language is -implemented (currently Ada 2022), and in addition a number -of GNAT specific extensions are recognized as follows: +If an argument of “All” is specified, the latest version of the Ada language +is implemented (currently Ada 2022) and, in addition, a number +of GNAT specific extensions are recognized. These extensions are listed +below. An argument of “On” has the same effect except that only +some, not all, of the listed extensions are enabled; those extensions +are identified below. @itemize * @@ -3636,11 +3639,7 @@ The Ada 202x @code{Static} aspect can be specified on Intrinsic imported functions and the compiler will evaluate some of these intrinsic statically, in particular the @code{Shift_Left} and @code{Shift_Right} intrinsics. -@item -@code{'Reduce} attribute - -This attribute part of the Ada 202x language definition is provided for -now under -gnatX to confirm and potentially refine its usage and syntax. +An Extensions_Allowed pragma argument of “On” enables this extension. @item @code{[]} aggregates @@ -3785,6 +3784,8 @@ define the same set of bindings and the component subtypes for for a given identifer must all statically match. Currently, the case of a binding for a nondiscrete component is not implemented. +An Extensions_Allowed pragma argument of “On” enables this extension. + @item Fixed lower bounds for array types and subtypes @@ -3833,6 +3834,8 @@ improve the efficiency of indexing operations, since the compiler statically knows the lower bound of unconstrained array formals when the formal’s subtype has index ranges with static fixed lower bounds. +An Extensions_Allowed pragma argument of “On” enables this extension. + @item Prefixed-view notation for calls to primitive subprograms of untagged types @@ -3851,6 +3854,8 @@ component is visible at the point of a selected_component using that name, preference is given to the component in a selected_component (as is currently the case for tagged types with such component names). +An Extensions_Allowed pragma argument of “On” enables this extension. + @item Expression defaults for generic formal functions @@ -5384,7 +5389,7 @@ decrease or increase in successive iterations of the loop. In its simplest form, just one expression is specified, whose value must increase or decrease on each iteration of the loop. -In a more complex form, multiple arguments can be given which are intepreted +In a more complex form, multiple arguments can be given which are interpreted in a nesting lexicographic manner. For example: @example @@ -6442,7 +6447,7 @@ appear at the start of the declarations in a subprogram body Note: This pragma is called @code{Post_Class} rather than @code{Post'Class} because the latter would not be strictly conforming to the allowed syntax for pragmas. The motivation -for provinding pragmas equivalent to the aspects is to allow a program +for providing pragmas equivalent to the aspects is to allow a program to be written using the pragmas, and then compiled if necessary using an Ada compiler that does not recognize the pragmas or aspects, but is prepared to ignore the pragmas. The assertion @@ -7758,7 +7763,7 @@ replacement of any dots in the unit name by the specified string literal. Note that Source_File_Name pragmas should not be used if you are using project files. The reason for this rule is that the project manager is not -aware of these pragmas, and so other tools that use the projet file would not +aware of these pragmas, and so other tools that use the project file would not be aware of the intended naming conventions. If you are using project files, file naming is controlled by Source_File_Name_Project pragmas, which are usually supplied automatically by the project manager. A pragma @@ -8407,7 +8412,7 @@ pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); This pragma specifies that the specified entity, which must be a variable declared in a library-level package, is to be marked as “Thread Local Storage” (@code{TLS}). On systems supporting this (which -include Windows, Solaris, GNU/Linux, and VxWorks 6), this causes each +include Windows, Solaris, GNU/Linux, and VxWorks), this causes each thread (and hence each Ada task) to see a distinct copy of the variable. The variable must not have default initialization, and if there is @@ -8817,7 +8822,7 @@ pragma Unsuppress (Duplicated_Tag_Check); This pragma is standard in Ada 2005. It is available in all earlier versions of Ada as an implementation-defined pragma. -Note that in addition to the checks defined in the Ada RM, GNAT recogizes a +Note that in addition to the checks defined in the Ada RM, GNAT recognizes a number of implementation-defined check names. See the description of pragma @code{Suppress} for full details. @@ -9109,7 +9114,7 @@ expression (which does not exist in Ada 83). Note if the second argument of @code{DETAILS} is a @code{local_NAME} then the second form is always understood. If the intention is to use the fourth form, then you can write @code{NAME & ""} to force the -intepretation as a `static_string_EXPRESSION'. +interpretation as a `static_string_EXPRESSION'. Note: if the first argument is a valid @code{TOOL_NAME}, it will be interpreted that way. The use of the @code{TOOL_NAME} argument is relevant only to users @@ -9925,7 +9930,7 @@ This aspect is equivalent to @ref{141,,attribute Object_Size}. @section Aspect Obsolescent -@geindex Obsolsecent +@geindex Obsolescent This aspect is equivalent to @ref{ac,,pragma Obsolescent}. Note that the evaluation of this aspect happens at the point of occurrence, it is not @@ -10981,7 +10986,7 @@ this attribute. @code{P'Library_Level}, where P is an entity name, returns a Boolean value which is True if the entity is declared at the library level, and False otherwise. Note that within a -generic instantition, the name of the generic unit denotes the +generic instantiation, the name of the generic unit denotes the instance, which means that this attribute can be used to test if a generic is instantiated at the library level, as shown in this example: @@ -11707,7 +11712,7 @@ an implicit dependency on this unit. @geindex System_Allocator_Alignment @code{Standard'System_Allocator_Alignment} (@code{Standard} is the only -allowed prefix) provides the observable guaranted to be honored by +allowed prefix) provides the observable guaranteed to be honored by the system allocator (malloc). This is a static value that can be used in user storage pools based on malloc either to reject allocation with alignment too large or to enable a realignment circuitry if the @@ -17856,7 +17861,7 @@ a distributed application. “The range of type System.RPC.Partition_Id. See E.5(14).” @end itemize -System.RPC.Partion_ID’Last is Integer’Last. See source file @code{s-rpc.ads}. +System.RPC.Partition_ID’Last is Integer’Last. See source file @code{s-rpc.ads}. @itemize * @@ -20874,7 +20879,7 @@ This package provides operations on directories. @item @code{Ada.Directories.Hierarchical_File_Names} `(A.16.1)' This package provides additional directory operations handling -hiearchical file names. +hierarchical file names. @item @code{Ada.Directories.Information} `(A.16)' @@ -21340,7 +21345,7 @@ only the tag value. This package provides the capability of associating arbitrary task-specific data with separate tasks. -@item @code{Ada.Task_Identifification} `(C.7.1)' +@item @code{Ada.Task_Identification} `(C.7.1)' This package provides capabilities for task identification. diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 7d96dbe..0f23d5b 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3,7 +3,7 @@ @setfilename gnat_ugn.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 5.1.1.@* +@*Generated by Sphinx 5.2.3.@* @end ifinfo @settitle GNAT User's Guide for Native Platforms @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Sep 26, 2022 +GNAT User's Guide for Native Platforms , Oct 27, 2022 AdaCore @@ -9881,7 +9881,17 @@ Suppress generation of cross-reference information. @item @code{-gnatX} -Enable GNAT implementation extensions and latest Ada version. +Enable core GNAT implementation extensions and latest Ada version. +@end table + +@geindex -gnatX0 (gcc) + + +@table @asis + +@item @code{-gnatX0} + +Enable all GNAT implementation extensions and latest Ada version. @end table @geindex -gnaty (gcc) @@ -14416,7 +14426,7 @@ This switch directs the compiler to implement the Ada 2022 version of the language. @end table -@geindex -gnatX (gcc) +@geindex -gnatX0 (gcc) @geindex Ada language extensions @@ -14425,7 +14435,7 @@ language. @table @asis -@item @code{-gnatX} (Enable GNAT Extensions) +@item @code{-gnatX0} (Enable GNAT Extensions) This switch directs the compiler to implement the latest version of the language (currently Ada 2022) and also to enable certain GNAT implementation @@ -14433,6 +14443,24 @@ extensions that are not part of any Ada standard. For a full list of these extensions, see the GNAT reference manual, @code{Pragma Extensions_Allowed}. @end table +@geindex -gnatX (gcc) + +@geindex Ada language extensions + +@geindex GNAT extensions + + +@table @asis + +@item @code{-gnatX} (Enable core GNAT Extensions) + +This switch is similar to -gnatX0 except that only some, not all, of the +GNAT-defined language extensions are enabled. For a list of the +extensions enabled by this switch, see the GNAT reference manual +@code{Pragma Extensions_Allowed} and the description of that pragma’s +“On” (as opposed to “All”) argument. +@end table + @node Character Set Control,File Naming Control,Compiling Different Versions of Ada,Compiler Switches @anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{31}@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{fb} @subsection Character Set Control @@ -16689,7 +16717,7 @@ development environments much more flexible. @subsection Examples of @code{gnatbind} Usage -Here are some examples of @code{gnatbind} invovations: +Here are some examples of @code{gnatbind} invocations: @quotation @@ -20765,7 +20793,7 @@ erroneous, and the compiler would be entitled to assume that However, in practice, this would cause some existing code that seems to work with no optimization to start failing at high -levels of optimzization. +levels of optimization. What the compiler does for such cases is to assume that marking a variable as aliased indicates that some “funny business” may @@ -21216,7 +21244,7 @@ To deal with the portability issue, and with the problem of mathematical versus run-time interpretation of the expressions in assertions, GNAT provides comprehensive control over the handling of intermediate overflow. GNAT can operate in three modes, and -furthemore, permits separate selection of operating modes for +furthermore, permits separate selection of operating modes for the expressions within assertions (here the term ‘assertions’ is used in the technical sense, which includes preconditions and so forth) and for expressions appearing outside assertions. @@ -27296,8 +27324,9 @@ change pragma Elaborate_All for unit "..." to Elaborate in unit "..." @end example This tactic is always suggested with the pragma @code{Elaborate_All} elimination -tactic. It offers a different alernative of guaranteeing that the argument of -the pragma will still be elaborated prior to the unit containing the pragma. +tactic. It offers a different alternative of guaranteeing that the argument +of the pragma will still be elaborated prior to the unit containing the +pragma. The programmer should update the pragma as advised, and rebuild the program. @@ -27670,7 +27699,7 @@ checks. The example above will still fail at run time with an ABE. A programmer should first compile the program with the default options, using none of the binder or compiler switches. If the binder succeeds in finding an -elaboration order, then apart from possible cases involing dispatching calls +elaboration order, then apart from possible cases involving dispatching calls and access-to-subprogram types, the program is free of elaboration errors. If it is important for the program to be portable to compilers other than GNAT, @@ -29319,8 +29348,8 @@ to permit their use in free software. @printindex ge -@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @anchor{cf}@w{ } +@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @c %**end of body @bye diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index e4187dd..4f764bf 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -500,7 +500,7 @@ package body Layout is if Is_Array_Type (E) and then Present (First_Index (E)) -- Skip types in error and then Number_Dimensions (E) = 1 - and then not Present (Packed_Array_Impl_Type (E)) + and then No (Packed_Array_Impl_Type (E)) and then Has_Pragma_Pack (E) and then Is_Constrained (E) and then Compile_Time_Known_Bounds (E) diff --git a/gcc/ada/libgnat/g-excact.ads b/gcc/ada/libgnat/g-excact.ads index 1101546..c2e0b30 100644 --- a/gcc/ada/libgnat/g-excact.ads +++ b/gcc/ada/libgnat/g-excact.ads @@ -71,8 +71,7 @@ package GNAT.Exception_Actions is -- If Action is null, this will in effect cancel all exception actions. procedure Register_Global_Unhandled_Action (Action : Exception_Action); - -- Similar to Register_Global_Action, called on unhandled exceptions - -- only. + -- Similar to Register_Global_Action, called on unhandled exceptions only procedure Register_Id_Action (Id : Exception_Id; @@ -90,7 +89,7 @@ package GNAT.Exception_Actions is -- an exception that is declared within an unlabeled block. -- -- Note: All non-predefined exceptions will return Null_Id for programs - -- compiled with pragma Restriction (No_Exception_Registration) + -- compiled with pragma Restrictions (No_Exception_Registration). function Is_Foreign_Exception (E : Exception_Occurrence) return Boolean; -- Tell whether the exception occurrence E represents a foreign exception, diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 8f903ca..9eb792e 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -73,15 +73,16 @@ package Opt is -- Ada_xxx) or generate an error (in case of -gnat83/95/xx switches). type Ada_Version_Type is - (Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2022, Ada_With_Extensions); + (Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2022, + Ada_With_Core_Extensions, Ada_With_All_Extensions); pragma Ordered (Ada_Version_Type); pragma Convention (C, Ada_Version_Type); -- Versions of Ada for Ada_Version below. Note that these are ordered, -- so that tests like Ada_Version >= Ada_95 are legitimate and useful. -- Think twice before using "="; Ada_Version >= Ada_2012 is more likely -- what you want, because it will apply to future versions of the language. - -- Note that Ada_With_Extensions should always be last since it should - -- always be a superset of the latest Ada version. + -- Note that Ada_With_All_Extensions should always be last since it should + -- always be a superset of the other Ada versions. -- WARNING: There is a matching C declaration of this type in fe.h @@ -111,7 +112,7 @@ package Opt is -- remains set to Ada_Version_Default). This is used in the rare cases -- (notably pragma Obsolescent) where we want the explicit version set. - Ada_Version_Runtime : Ada_Version_Type := Ada_With_Extensions; + Ada_Version_Runtime : Ada_Version_Type := Ada_With_All_Extensions; -- GNAT -- Ada version used to compile the runtime. Used to set Ada_Version (but -- not Ada_Version_Explicit) when compiling predefined or internal units. @@ -630,11 +631,16 @@ package Opt is -- Set to True to convert nonbinary modular additions into code -- that relies on the front-end expansion of operator Mod. - function Extensions_Allowed return Boolean is - (Ada_Version = Ada_With_Extensions); + function All_Extensions_Allowed return Boolean is + (Ada_Version = Ada_With_All_Extensions); -- True if GNAT specific language extensions are allowed. See GNAT RM for -- details. + function Core_Extensions_Allowed return Boolean is + (Ada_Version >= Ada_With_Core_Extensions); + -- True if some but not all GNAT specific language extensions are allowed. + -- See GNAT RM for details. + type External_Casing_Type is ( As_Is, -- External names cased as they appear in the Ada source Uppercase, -- External names forced to all uppercase letters diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 5684839..aac4589 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -2839,7 +2839,8 @@ package body Ch3 is else P_Index_Subtype_Def_With_Fixed_Lower_Bound (Subtype_Mark_Node); - Error_Msg_GNAT_Extension ("fixed-lower-bound array", Token_Ptr); + Error_Msg_GNAT_Extension ("fixed-lower-bound array", Token_Ptr, + Is_Core_Extension => True); end if; exit when Token in Tok_Right_Paren | Tok_Of; @@ -2909,7 +2910,8 @@ package body Ch3 is (Subtype_Mark_Node); Error_Msg_GNAT_Extension - ("fixed-lower-bound array", Token_Ptr); + ("fixed-lower-bound array", Token_Ptr, + Is_Core_Extension => True); end if; exit when Token in Tok_Right_Paren | Tok_Of; @@ -3412,7 +3414,8 @@ package body Ch3 is -- later during analysis), and scan to the next token. if Token = Tok_Box then - Error_Msg_GNAT_Extension ("fixed-lower-bound array", Token_Ptr); + Error_Msg_GNAT_Extension ("fixed-lower-bound array", Token_Ptr, + Is_Core_Extension => True); Expr_Node := Empty; Scan; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 0dc6c8a..82b09b2 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1775,7 +1775,7 @@ package body Ch4 is if Token = Tok_Identifier then Id := P_Defining_Identifier; if Token = Tok_Greater then - if Extensions_Allowed then + if Core_Extensions_Allowed then Set_Box_Present (Assoc_Node); Set_Binding_Chars (Assoc_Node, Chars (Id)); Box_Present := True; @@ -1813,7 +1813,7 @@ package body Ch4 is if Token = Tok_Identifier then Id := P_Defining_Identifier; - if not Extensions_Allowed then + if not Core_Extensions_Allowed then Error_Msg_GNAT_Extension ("IS following component association", Token_Ptr); elsif Box_With_Identifier_Present then diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index e1cf5ba..0adb702 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -73,10 +73,12 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is -- Check the expression of the specified argument to make sure that it -- is a string literal. If not give error and raise Error_Resync. - procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id); + procedure Check_Arg_Is_On_Or_Off + (Arg : Node_Id; All_OK_Too : Boolean := False); -- Check the expression of the specified argument to make sure that it -- is an identifier which is either ON or OFF, and if not, then issue - -- an error message and raise Error_Resync. + -- an error message and raise Error_Resync. If All_OK_Too is True, + -- then an ALL identifer is also acceptable. procedure Check_No_Identifier (Arg : Node_Id); -- Checks that the given argument does not have an identifier. If @@ -167,17 +169,26 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is -- Check_Arg_Is_On_Or_Off -- ---------------------------- - procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is + procedure Check_Arg_Is_On_Or_Off + (Arg : Node_Id; All_OK_Too : Boolean := False) + is Argx : constant Node_Id := Expression (Arg); - + Error : Boolean := Nkind (Expression (Arg)) /= N_Identifier; begin - if Nkind (Expression (Arg)) /= N_Identifier - or else Chars (Argx) not in Name_On | Name_Off - then + if not Error then + Error := (Chars (Argx) not in Name_On | Name_Off) + and then not (All_OK_Too and Chars (Argx) = Name_All); + end if; + if Error then Error_Msg_Name_2 := Name_On; Error_Msg_Name_3 := Name_Off; - Error_Msg_N ("argument for pragma% must be% or%", Argx); + if All_OK_Too then + Error_Msg_Name_4 := Name_All; + Error_Msg_N ("argument for pragma% must be% or% or%", Argx); + else + Error_Msg_N ("argument for pragma% must be% or%", Argx); + end if; raise Error_Resync; end if; end Check_Arg_Is_On_Or_Off; @@ -414,7 +425,7 @@ begin -- Extensions_Allowed (GNAT) -- ------------------------------- - -- pragma Extensions_Allowed (Off | On) + -- pragma Extensions_Allowed (Off | On | All) -- The processing for pragma Extensions_Allowed must be done at -- parse time, since extensions mode may affect what is accepted. @@ -422,10 +433,12 @@ begin when Pragma_Extensions_Allowed => Check_Arg_Count (1); Check_No_Identifier (Arg1); - Check_Arg_Is_On_Or_Off (Arg1); + Check_Arg_Is_On_Or_Off (Arg1, All_OK_Too => True); if Chars (Expression (Arg1)) = Name_On then - Ada_Version := Ada_With_Extensions; + Ada_Version := Ada_With_Core_Extensions; + elsif Chars (Expression (Arg1)) = Name_All then + Ada_Version := Ada_With_All_Extensions; else Ada_Version := Ada_Version_Explicit; end if; diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index 983a90b..43939a2 100644 --- a/gcc/ada/pprint.adb +++ b/gcc/ada/pprint.adb @@ -114,7 +114,7 @@ package body Pprint is Num : Natural := 1) return String is begin - if not Present (List) then + if No (List) then if First or else not Add_Paren then return ""; else @@ -229,7 +229,7 @@ package body Pprint is -- is not prepared to deal with a zero-length result. elsif Null_Record_Present (Expr) - or else not Present (First (Component_Associations (Expr))) + or else No (First (Component_Associations (Expr))) then return ("(null record)"); diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index cda13d4..2c22938 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -1668,7 +1668,7 @@ package body Rtsfind is -- Load unit if unit not previously loaded - if not Present (U.Entity) then + if No (U.Entity) then Load_RTU (U_Id, Id => E); end if; @@ -1687,7 +1687,7 @@ package body Rtsfind is E1 := First_Entity (Pkg_Ent); while Present (E1) loop if Ename = Chars (E1) then - pragma Assert (not Present (Found_E)); + pragma Assert (No (Found_E)); Found_E := E1; end if; diff --git a/gcc/ada/sa_messages.adb b/gcc/ada/sa_messages.adb deleted file mode 100644 index b9b4e93..0000000 --- a/gcc/ada/sa_messages.adb +++ /dev/null @@ -1,539 +0,0 @@ ------------------------------------------------------------------------------- --- C O D E P E E R / S P A R K -- --- -- --- Copyright (C) 2015-2022, AdaCore -- --- -- --- This 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. This software is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- --- License for more details. You should have received a copy of the GNU -- --- General Public License distributed with this software; see file -- --- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- --- of the license. -- --- -- ------------------------------------------------------------------------------- - -pragma Ada_2012; - -with Ada.Directories; use Ada.Directories; -with Ada.Strings.Unbounded.Hash; - -with Ada.Text_IO; use Ada.Text_IO; -with GNATCOLL.JSON; use GNATCOLL.JSON; - -package body SA_Messages is - - ----------------------- - -- Local subprograms -- - ----------------------- - - function "<" (Left, Right : SA_Message) return Boolean is - (if Left.Kind /= Right.Kind then - Left.Kind < Right.Kind - else - Left.Kind in Check_Kind - and then Left.Check_Result < Right.Check_Result); - - function "<" (Left, Right : Simple_Source_Location) return Boolean is - (if Left.File_Name /= Right.File_Name then - Left.File_Name < Right.File_Name - elsif Left.Line /= Right.Line then - Left.Line < Right.Line - else - Left.Column < Right.Column); - - function "<" (Left, Right : Source_Locations) return Boolean is - (if Left'Length /= Right'Length then - Left'Length < Right'Length - elsif Left'Length = 0 then - False - elsif Left (Left'Last) /= Right (Right'Last) then - Left (Left'Last) < Right (Right'Last) - else - Left (Left'First .. Left'Last - 1) < - Right (Right'First .. Right'Last - 1)); - - function "<" (Left, Right : Source_Location) return Boolean is - (Left.Locations < Right.Locations); - - function Base_Location - (Location : Source_Location) return Simple_Source_Location is - (Location.Locations (1)); - - function Hash (Key : SA_Message) return Hash_Type; - function Hash (Key : Source_Location) return Hash_Type; - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Message_And_Location) return Boolean is - (if Left.Message = Right.Message - then Left.Location < Right.Location - else Left.Message < Right.Message); - - ------------ - -- Column -- - ------------ - - function Column (Location : Source_Location) return Column_Number is - (Base_Location (Location).Column); - - --------------- - -- File_Name -- - --------------- - - function File_Name (Location : Source_Location) return String is - (To_String (Base_Location (Location).File_Name)); - - function File_Name (Location : Source_Location) return Unbounded_String is - (Base_Location (Location).File_Name); - - ------------------------ - -- Enclosing_Instance -- - ------------------------ - - function Enclosing_Instance - (Location : Source_Location) return Source_Location_Or_Null is - (Count => Location.Count - 1, - Locations => Location.Locations (2 .. Location.Count)); - - ---------- - -- Hash -- - ---------- - - function Hash (Key : Message_And_Location) return Hash_Type is - (Hash (Key.Message) + Hash (Key.Location)); - - function Hash (Key : SA_Message) return Hash_Type is - begin - return Result : Hash_Type := - Hash_Type'Mod (Message_Kind'Pos (Key.Kind)) - do - if Key.Kind in Check_Kind then - Result := Result + - Hash_Type'Mod (SA_Check_Result'Pos (Key.Check_Result)); - end if; - end return; - end Hash; - - function Hash (Key : Source_Location) return Hash_Type is - begin - return Result : Hash_Type := Hash_Type'Mod (Key.Count) do - for Loc of Key.Locations loop - Result := Result + Hash (Loc.File_Name); - Result := Result + Hash_Type'Mod (Loc.Line); - Result := Result + Hash_Type'Mod (Loc.Column); - end loop; - end return; - end Hash; - - --------------- - -- Iteration -- - --------------- - - function Iteration (Location : Source_Location) return Iteration_Id is - (Base_Location (Location).Iteration); - - ---------- - -- Line -- - ---------- - - function Line (Location : Source_Location) return Line_Number is - (Base_Location (Location).Line); - - -------------- - -- Location -- - -------------- - - function Location - (Item : Message_And_Location) return Source_Location is - (Item.Location); - - ---------- - -- Make -- - ---------- - - function Make - (File_Name : String; - Line : Line_Number; - Column : Column_Number; - Iteration : Iteration_Id; - Enclosing_Instance : Source_Location_Or_Null) return Source_Location - is - begin - return Result : Source_Location - (Count => Enclosing_Instance.Count + 1) - do - Result.Locations (1) := - (File_Name => To_Unbounded_String (File_Name), - Line => Line, - Column => Column, - Iteration => Iteration); - - Result.Locations (2 .. Result.Count) := Enclosing_Instance.Locations; - end return; - end Make; - - ------------------ - -- Make_Msg_Loc -- - ------------------ - - function Make_Msg_Loc - (Msg : SA_Message; - Loc : Source_Location) return Message_And_Location - is - begin - return Message_And_Location'(Count => Loc.Count, - Message => Msg, - Location => Loc); - end Make_Msg_Loc; - - ------------- - -- Message -- - ------------- - - function Message (Item : Message_And_Location) return SA_Message is - (Item.Message); - - package Field_Names is - - -- A Source_Location value is represented in JSON as a two or three - -- field value having fields Message_Kind (a string) and Locations (an - -- array); if the Message_Kind indicates a check kind, then a third - -- field is present: Check_Result (a string). The element type of the - -- Locations array is a value having at least 4 fields: - -- File_Name (a string), Line (an integer), Column (an integer), - -- and Iteration_Kind (an integer); if the Iteration_Kind field - -- has the value corresponding to the enumeration literal Numbered, - -- then two additional integer fields are present, Iteration_Number - -- and Iteration_Of_Total. - - Check_Result : constant String := "Check_Result"; - Column : constant String := "Column"; - File_Name : constant String := "File_Name"; - Iteration_Kind : constant String := "Iteration_Kind"; - Iteration_Number : constant String := "Iteration_Number"; - Iteration_Of_Total : constant String := "Iteration_Total"; - Line : constant String := "Line"; - Locations : constant String := "Locations"; - Message_Kind : constant String := "Message_Kind"; - Messages : constant String := "Messages"; - end Field_Names; - - package body Writing is - File : File_Type; - -- The file to which output will be written (in Close, not in Write) - - Messages : JSON_Array; - -- Successive calls to Write append messages to this list - - ----------------------- - -- Local subprograms -- - ----------------------- - - function To_JSON_Array - (Locations : Source_Locations) return JSON_Array; - -- Represent a Source_Locations array as a JSON_Array - - function To_JSON_Value - (Location : Simple_Source_Location) return JSON_Value; - -- Represent a Simple_Source_Location as a JSON_Value - - ----------- - -- Close -- - ----------- - - procedure Close is - Value : constant JSON_Value := Create_Object; - - begin - -- only one field for now - Set_Field (Value, Field_Names.Messages, Messages); - Put_Line (File, Write (Item => Value, Compact => False)); - Clear (Messages); - Close (File => File); - end Close; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open return Boolean is (Is_Open (File)); - - ---------- - -- Open -- - ---------- - - procedure Open (File_Name : String) is - begin - Create (File => File, Mode => Out_File, Name => File_Name); - Clear (Messages); - end Open; - - ------------------- - -- To_JSON_Array -- - ------------------- - - function To_JSON_Array - (Locations : Source_Locations) return JSON_Array - is - begin - return Result : JSON_Array := Empty_Array do - for Location of Locations loop - Append (Result, To_JSON_Value (Location)); - end loop; - end return; - end To_JSON_Array; - - ------------------- - -- To_JSON_Value -- - ------------------- - - function To_JSON_Value - (Location : Simple_Source_Location) return JSON_Value - is - begin - return Result : constant JSON_Value := Create_Object do - Set_Field (Result, Field_Names.File_Name, Location.File_Name); - Set_Field (Result, Field_Names.Line, Integer (Location.Line)); - Set_Field (Result, Field_Names.Column, Integer (Location.Column)); - Set_Field (Result, Field_Names.Iteration_Kind, Integer'( - Iteration_Kind'Pos (Location.Iteration.Kind))); - - if Location.Iteration.Kind = Numbered then - Set_Field (Result, Field_Names.Iteration_Number, - Location.Iteration.Number); - Set_Field (Result, Field_Names.Iteration_Of_Total, - Location.Iteration.Of_Total); - end if; - end return; - end To_JSON_Value; - - ----------- - -- Write -- - ----------- - - procedure Write (Message : SA_Message; Location : Source_Location) is - Value : constant JSON_Value := Create_Object; - - begin - Set_Field (Value, Field_Names.Message_Kind, Message.Kind'Img); - - if Message.Kind in Check_Kind then - Set_Field - (Value, Field_Names.Check_Result, Message.Check_Result'Img); - end if; - - Set_Field - (Value, Field_Names.Locations, To_JSON_Array (Location.Locations)); - Append (Messages, Value); - end Write; - end Writing; - - package body Reading is - File : File_Type; - -- The file from which messages are read (in Open, not in Read) - - Messages : JSON_Array; - -- The list of messages that were read in from File - - Next_Index : Positive; - -- The index of the message in Messages which will be returned by the - -- next call to Get. - - Parse_Full_Path : Boolean := True; - -- if the full path or only the base name of the file should be parsed - - ----------- - -- Close -- - ----------- - - procedure Close is - begin - Clear (Messages); - Close (File); - end Close; - - ---------- - -- Done -- - ---------- - - function Done return Boolean is (Next_Index > Length (Messages)); - - --------- - -- Get -- - --------- - - function Get return Message_And_Location is - Value : constant JSON_Value := Get (Messages, Next_Index); - - function Get_Message (Kind : Message_Kind) return SA_Message; - -- Return SA_Message of given kind, filling in any non-discriminant - -- by reading from Value. - - function Make - (Location : Source_Location; - Message : SA_Message) return Message_And_Location; - -- Constructor - - function To_Location - (Encoded : JSON_Array; - Full_Path : Boolean) return Source_Location; - -- Decode a Source_Location from JSON_Array representation - - function To_Simple_Location - (Encoded : JSON_Value; - Full_Path : Boolean) return Simple_Source_Location; - -- Decode a Simple_Source_Location from JSON_Value representation - - ----------------- - -- Get_Message -- - ----------------- - - function Get_Message (Kind : Message_Kind) return SA_Message is - begin - -- If we had AI12-0086, then we could use aggregates here (which - -- would be better than field-by-field assignment for the usual - -- maintainability reasons). But we don't, so we won't. - - return Result : SA_Message (Kind => Kind) do - if Kind in Check_Kind then - Result.Check_Result := - SA_Check_Result'Value - (Get (Value, Field_Names.Check_Result)); - end if; - end return; - end Get_Message; - - ---------- - -- Make -- - ---------- - - function Make - (Location : Source_Location; - Message : SA_Message) return Message_And_Location - is - (Count => Location.Count, Message => Message, Location => Location); - - ----------------- - -- To_Location -- - ----------------- - - function To_Location - (Encoded : JSON_Array; - Full_Path : Boolean) return Source_Location is - begin - return Result : Source_Location (Count => Length (Encoded)) do - for I in Result.Locations'Range loop - Result.Locations (I) := - To_Simple_Location (Get (Encoded, I), Full_Path); - end loop; - end return; - end To_Location; - - ------------------------ - -- To_Simple_Location -- - ------------------------ - - function To_Simple_Location - (Encoded : JSON_Value; - Full_Path : Boolean) return Simple_Source_Location - is - function Get_Iteration_Id - (Kind : Iteration_Kind) return Iteration_Id; - -- Given the discriminant for an Iteration_Id value, return the - -- entire value. - - ---------------------- - -- Get_Iteration_Id -- - ---------------------- - - function Get_Iteration_Id (Kind : Iteration_Kind) - return Iteration_Id - is - begin - -- Initialize non-discriminant fields, if any - - return Result : Iteration_Id (Kind => Kind) do - if Kind = Numbered then - Result := - (Kind => Numbered, - Number => - Get (Encoded, Field_Names.Iteration_Number), - Of_Total => - Get (Encoded, Field_Names.Iteration_Of_Total)); - end if; - end return; - end Get_Iteration_Id; - - -- Local variables - - FN : constant Unbounded_String := - Get (Encoded, Field_Names.File_Name); - - -- Start of processing for To_Simple_Location - - begin - return - (File_Name => - (if Full_Path then - FN - else - To_Unbounded_String (Simple_Name (To_String (FN)))), - Line => - Line_Number (Integer'(Get (Encoded, Field_Names.Line))), - Column => - Column_Number (Integer'(Get (Encoded, Field_Names.Column))), - Iteration => - Get_Iteration_Id - (Kind => Iteration_Kind'Val (Integer'(Get - (Encoded, Field_Names.Iteration_Kind))))); - end To_Simple_Location; - - -- Start of processing for Get - - begin - Next_Index := Next_Index + 1; - - return Make - (Message => - Get_Message - (Message_Kind'Value (Get (Value, Field_Names.Message_Kind))), - Location => - To_Location - (Get (Value, Field_Names.Locations), Parse_Full_Path)); - end Get; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open return Boolean is (Is_Open (File)); - - ---------- - -- Open -- - ---------- - - procedure Open (File_Name : String; Full_Path : Boolean := True) is - File_Text : Unbounded_String := Null_Unbounded_String; - - begin - Parse_Full_Path := Full_Path; - Open (File => File, Mode => In_File, Name => File_Name); - - -- File read here, not in Get, but that's an implementation detail - - while not End_Of_File (File) loop - Append (File_Text, Get_Line (File)); - end loop; - - Messages := Get (Read (File_Text), Field_Names.Messages); - Next_Index := 1; - end Open; - end Reading; - -end SA_Messages; diff --git a/gcc/ada/sa_messages.ads b/gcc/ada/sa_messages.ads deleted file mode 100644 index c448397..0000000 --- a/gcc/ada/sa_messages.ads +++ /dev/null @@ -1,267 +0,0 @@ ------------------------------------------------------------------------------- --- C O D E P E E R / S P A R K -- --- -- --- Copyright (C) 2015-2022, AdaCore -- --- -- --- This 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. This software is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- --- License for more details. You should have received a copy of the GNU -- --- General Public License distributed with this software; see file -- --- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- --- of the license. -- --- -- ------------------------------------------------------------------------------- - -pragma Ada_2012; - -with Ada.Containers; use Ada.Containers; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; - -package SA_Messages is - - -- This package can be used for reading/writing a file containing a - -- sequence of static anaysis results. Each element can describe a runtime - -- check whose outcome has been statically determined, or it might be a - -- warning or diagnostic message. It is expected that typically CodePeer - -- will do the writing and SPARK will do the reading; this will allow SPARK - -- to get the benefit of CodePeer's analysis. - -- - -- Each item is represented as a pair consisting of a message and an - -- associated source location. Source locations may refer to a location - -- within the expansion of an instance of a generic; this is represented - -- by combining the corresponding location within the generic with the - -- location of the instance (repeated if the instance itself occurs within - -- a generic). In addition, the type Iteration_Id is intended for use in - -- distinguishing messages which refer to a specific iteration of a loop - -- (this case can arise, for example, if CodePeer chooses to unroll a - -- for-loop). This data structure is only general enough to support the - -- kinds of unrolling that are currently planned for CodePeer. For - -- example, an Iteration_Id can only identify an iteration of the nearest - -- enclosing loop of the associated File/Line/Column source location. - -- This is not a problem because CodePeer doesn't unroll loops which - -- contain other loops. - - type Message_Kind is ( - - -- Check kinds - - Array_Index_Check, - Divide_By_Zero_Check, - Tag_Check, - Discriminant_Check, - Range_Check, - Overflow_Check, - Assertion_Check, - - -- Warning kinds - - Suspicious_Range_Precondition_Warning, - Suspicious_First_Precondition_Warning, - Suspicious_Input_Warning, - Suspicious_Constant_Operation_Warning, - Unread_In_Out_Parameter_Warning, - Unassigned_In_Out_Parameter_Warning, - Non_Analyzed_Call_Warning, - Procedure_Does_Not_Return_Warning, - Check_Fails_On_Every_Call_Warning, - Unknown_Call_Warning, - Dead_Store_Warning, - Dead_Outparam_Store_Warning, - Potentially_Dead_Store_Warning, - Same_Value_Dead_Store_Warning, - Dead_Block_Warning, - Infinite_Loop_Warning, - Dead_Edge_Warning, - Plain_Dead_Edge_Warning, - True_Dead_Edge_Warning, - False_Dead_Edge_Warning, - True_Condition_Dead_Edge_Warning, - False_Condition_Dead_Edge_Warning, - Unrepeatable_While_Loop_Warning, - Dead_Block_Continuation_Warning, - Local_Lock_Of_Global_Object_Warning, - Analyzed_Module_Warning, - Non_Analyzed_Module_Warning, - Non_Analyzed_Procedure_Warning, - Incompletely_Analyzed_Procedure_Warning); - - -- Assertion_Check includes checks for user-defined PPCs (both specific - -- and class-wide), Assert pragma checks, subtype predicate checks, - -- type invariant checks (specific and class-wide), and checks for - -- implementation-defined assertions such as Assert_And_Cut, Assume, - -- Contract_Cases, Default_Initial_Condition, Initial_Condition, - -- Loop_Invariant, Loop_Variant, Refined_Post, and Subprogram_Variant. - -- - -- It might be nice to distinguish these different kinds of assertions - -- as is done in SPARK's VC_Kind enumeration type, but any distinction - -- which isn't already present in CP's BE_Message_Subkind enumeration type - -- would require more work on the CP side. - -- - -- The warning kinds are pretty much a copy of the set of - -- Be_Message_Subkind values for which CP's Is_Warning predicate returns - -- True; see descriptive comment for each in CP's message_kinds.ads . - - subtype Check_Kind is Message_Kind - range Array_Index_Check .. Assertion_Check; - subtype Warning_Kind is Message_Kind - range Message_Kind'Succ (Check_Kind'Last) .. Message_Kind'Last; - - -- Possible outcomes of the static analysis of a runtime check - -- - -- Not_Statically_Known_With_Low_Severity could be used instead of of - -- Not_Statically_Known if there is some reason to believe that (although - -- the tool couldn't prove it) the check is likely to always pass (in CP - -- terms, if the corresponding CP message has severity Low as opposed to - -- Medium). It's not clear yet whether SPARK will care about this - -- distinction. - - type SA_Check_Result is - (Statically_Known_Success, - Not_Statically_Known_With_Low_Severity, - Not_Statically_Known, - Statically_Known_Failure); - - type SA_Message (Kind : Message_Kind := Message_Kind'Last) is record - case Kind is - when Check_Kind => - Check_Result : SA_Check_Result; - - when Warning_Kind => - null; - end case; - end record; - - type Source_Location_Or_Null (<>) is private; - Null_Location : constant Source_Location_Or_Null; - subtype Source_Location is Source_Location_Or_Null with - Dynamic_Predicate => Source_Location /= Null_Location; - - type Line_Number is new Positive; - type Column_Number is new Positive; - - function File_Name (Location : Source_Location) return String; - function File_Name (Location : Source_Location) return Unbounded_String; - function Line (Location : Source_Location) return Line_Number; - function Column (Location : Source_Location) return Column_Number; - - type Iteration_Kind is (None, Initial, Subsequent, Numbered); - -- None is for the usual no-unrolling case. - -- Initial and Subsequent are for use in the case where only the first - -- iteration of a loop (or some part thereof, such as the termination - -- test of a while-loop) is unrolled. - -- Numbered is for use in the case where a for-loop with a statically - -- known number of iterations is fully unrolled. - - subtype Iteration_Number is Integer range 1 .. 255; - subtype Iteration_Total is Integer range 2 .. 255; - - type Iteration_Id (Kind : Iteration_Kind := None) is record - case Kind is - when Numbered => - Number : Iteration_Number; - Of_Total : Iteration_Total; - when others => - null; - end case; - end record; - - function Iteration (Location : Source_Location) return Iteration_Id; - - function Enclosing_Instance - (Location : Source_Location) return Source_Location_Or_Null; - -- For a source location occurring within the expansion of an instance of a - -- generic unit, the Line, Column, and File_Name selectors will indicate a - -- location within the generic; the Enclosing_Instance selector yields the - -- location of the declaration of the instance. - - function Make - (File_Name : String; - Line : Line_Number; - Column : Column_Number; - Iteration : Iteration_Id; - Enclosing_Instance : Source_Location_Or_Null) return Source_Location; - -- Constructor - - type Message_And_Location (<>) is private; - - function Location (Item : Message_And_Location) return Source_Location; - function Message (Item : Message_And_Location) return SA_Message; - - function Make_Msg_Loc - (Msg : SA_Message; - Loc : Source_Location) return Message_And_Location; - -- Selectors - - function "<" (Left, Right : Message_And_Location) return Boolean; - function Hash (Key : Message_And_Location) return Hash_Type; - -- Actuals for container instances - - File_Extension : constant String; -- ".json" (but could change in future) - -- Clients may wish to use File_Extension in constructing - -- File_Name parameters for calls to Open. - - package Writing is - function Is_Open return Boolean; - - procedure Open (File_Name : String) with - Precondition => not Is_Open, - Postcondition => Is_Open; - -- Behaves like Text_IO.Create with respect to error cases - - procedure Write (Message : SA_Message; Location : Source_Location); - - procedure Close with - Precondition => Is_Open, - Postcondition => not Is_Open; - -- Behaves like Text_IO.Close with respect to error cases - end Writing; - - package Reading is - function Is_Open return Boolean; - - procedure Open (File_Name : String; Full_Path : Boolean := True) with - Precondition => not Is_Open, - Postcondition => Is_Open; - -- Behaves like Text_IO.Open with respect to error cases - - function Done return Boolean with - Precondition => Is_Open; - - function Get return Message_And_Location with - Precondition => not Done; - - procedure Close with - Precondition => Is_Open, - Postcondition => not Is_Open; - -- Behaves like Text_IO.Close with respect to error cases - end Reading; - -private - type Simple_Source_Location is record - File_Name : Unbounded_String := Null_Unbounded_String; - Line : Line_Number := Line_Number'Last; - Column : Column_Number := Column_Number'Last; - Iteration : Iteration_Id := (Kind => None); - end record; - - type Source_Locations is - array (Natural range <>) of Simple_Source_Location; - - type Source_Location_Or_Null (Count : Natural) is record - Locations : Source_Locations (1 .. Count); - end record; - - Null_Location : constant Source_Location_Or_Null := - (Count => 0, Locations => (others => <>)); - - type Message_And_Location (Count : Positive) is record - Message : SA_Message; - Location : Source_Location (Count => Count); - end record; - - File_Extension : constant String := ".json"; -end SA_Messages; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 5db1fce..87a8c1a 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2355,7 +2355,7 @@ package body Sem_Aggr is -- duplicate the expression tree to analyze the copy and -- perform the required check. - elsif not Present (Etype (Expression (Assoc))) then + elsif No (Etype (Expression (Assoc))) then declare Save_Analysis : constant Boolean := Full_Analysis; Expr : constant Node_Id := @@ -5747,7 +5747,7 @@ package body Sem_Aggr is -- Ignore hidden components associated with the position of the -- interface tags: these are initialized dynamically. - if not Present (Related_Type (Component)) then + if No (Related_Type (Component)) then Error_Msg_NE ("no value supplied for component &!", N, Component); end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index d27d956..299ea04 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3888,7 +3888,7 @@ package body Sem_Attr is elsif (Is_Generic_Type (P_Type) or else Is_Generic_Actual_Type (P_Type)) - and then Extensions_Allowed + and then All_Extensions_Allowed then return; end if; @@ -6425,7 +6425,7 @@ package body Sem_Attr is -- type to the pool object's type. else - if not Present (Get_Rep_Pragma (Etype (Entity (N)), + if No (Get_Rep_Pragma (Etype (Entity (N)), Name_Simple_Storage_Pool_Type)) then Error_Attr_P diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 2810d3e..bb732b7 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -1611,7 +1611,7 @@ package body Sem_Case is begin while Present (Comp) loop if Chars (First (Choices (Comp))) = Orig_Name then - pragma Assert (not Present (Matching_Comp)); + pragma Assert (No (Matching_Comp)); Matching_Comp := Comp; end if; @@ -3581,7 +3581,7 @@ package body Sem_Case is -- Hold on, maybe it isn't a complete mess after all. - if Extensions_Allowed and then Subtyp /= Any_Type then + if Core_Extensions_Allowed and then Subtyp /= Any_Type then Check_Composite_Case_Selector; Check_Case_Pattern_Choices; end if; @@ -3864,7 +3864,7 @@ package body Sem_Case is function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean is E : Node_Id := Expr; begin - if not Extensions_Allowed then + if not Core_Extensions_Allowed then return False; end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ab2e182..0b7b7c9 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3121,7 +3121,6 @@ package body Sem_Ch12 is if Present (Aspect_Specifications (Gen_Decl)) then if No (Aspect_Specifications (N)) then Set_Aspect_Specifications (N, New_List); - Set_Has_Aspects (N); end if; declare @@ -14086,7 +14085,7 @@ package body Sem_Ch12 is -- a full view, then we'll retrieve that. if Ekind (A_Gen_T) = E_Incomplete_Type - and then not Present (Full_View (Act_T)) + and then No (Full_View (Act_T)) then null; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 54b10dd..2eb1a69 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1271,7 +1271,7 @@ package body Sem_Ch13 is | Aspect_Full_Access_Only | Aspect_Import and then (A_Id /= Aspect_Preelaborable_Initialization - or else not Present (Expression (ASN))) + or else No (Expression (ASN))) then Make_Pragma_From_Boolean_Aspect (ASN); end if; @@ -1327,7 +1327,7 @@ package body Sem_Ch13 is if not Is_Entity_Name (Expression (ASN)) or else not Is_Object (Entity (Expression (ASN))) or else - not Present (Find_Aspect (Etype (Expression (ASN)), + No (Find_Aspect (Etype (Expression (ASN)), Aspect_Storage_Model_Type)) then Error_Msg_N @@ -1915,7 +1915,7 @@ package body Sem_Ch13 is -- aspects are replaced with pragmas at the freeze point in -- Make_Pragma_From_Boolean_Aspect. - if not Present (Expr) + if No (Expr) or else Is_True (Static_Boolean (Expr)) then if A_Id = Aspect_Import then @@ -2399,16 +2399,17 @@ package body Sem_Ch13 is if not Is_Expression_Function (E) and then - not (Extensions_Allowed and then Is_Imported_Intrinsic) + not (All_Extensions_Allowed and then Is_Imported_Intrinsic) then - if Extensions_Allowed then + if All_Extensions_Allowed then Error_Msg_N ("aspect % requires intrinsic or expression function", Aspect); elsif Is_Imported_Intrinsic then Error_Msg_GNAT_Extension - ("aspect % on intrinsic function", Sloc (Aspect)); + ("aspect % on intrinsic function", Sloc (Aspect), + Is_Core_Extension => True); else Error_Msg_N @@ -4212,7 +4213,7 @@ package body Sem_Ch13 is goto Continue; when Aspect_Designated_Storage_Model => - if not Extensions_Allowed then + if not All_Extensions_Allowed then Error_Msg_GNAT_Extension ("aspect %", Sloc (Aspect)); elsif not Is_Type (E) @@ -4227,7 +4228,7 @@ package body Sem_Ch13 is goto Continue; when Aspect_Storage_Model_Type => - if not Extensions_Allowed then + if not All_Extensions_Allowed then Error_Msg_GNAT_Extension ("aspect %", Sloc (Aspect)); elsif not Is_Type (E) @@ -7547,7 +7548,7 @@ package body Sem_Ch13 is else Analyze_And_Resolve (Expr); - if not Present (Get_Rep_Pragma + if No (Get_Rep_Pragma (Etype (Expr), Name_Simple_Storage_Pool_Type)) then Error_Msg_N @@ -16511,7 +16512,7 @@ package body Sem_Ch13 is begin for FP of Profiles loop - if not Present (Formal) then + if No (Formal) then Is_Error := True; Report_Argument_Error ("missing formal of }", Subt => FP.Subt); exit; @@ -16582,7 +16583,7 @@ package body Sem_Ch13 is -- If Addr_Type is not present as the first association, then we default -- it to System.Address. - elsif not Present (Addr_Type) then + elsif No (Addr_Type) then Addr_Type := RTE (RE_Address); end if; @@ -17251,7 +17252,7 @@ package body Sem_Ch13 is Param_Type := Standard_String; end if; - if not Overloaded and then not Present (Entity (Func_Name)) then + if not Overloaded and then No (Entity (Func_Name)) then -- The aspect is specified by a subprogram name, which -- may be an operator name given originally by a string. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 00c2e67..90af320 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2668,7 +2668,7 @@ package body Sem_Ch3 is -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes goes to -- Original_Node if needed, hence test for Standard_False.) - if not Present (Expr) + if No (Expr) or else (Is_Entity_Name (Expr) and then Entity (Expr) = Standard_True) or else @@ -3519,7 +3519,7 @@ package body Sem_Ch3 is -- Initialize the list of primitive operations to an empty list, -- to cover tagged types as well as untagged types. For untagged -- types this is used either to analyze the call as legal when - -- Extensions_Allowed is True, or to issue a better error message + -- Core_Extensions_Allowed is True, or to issue a better error message -- otherwise. Set_Direct_Primitive_Operations (T, New_Elmt_List); @@ -5730,7 +5730,7 @@ package body Sem_Ch3 is -- operations to an empty list. if Is_Tagged_Type (Id) - or else Extensions_Allowed + or else Core_Extensions_Allowed then Set_Direct_Primitive_Operations (Id, New_Elmt_List); end if; @@ -11050,7 +11050,7 @@ package body Sem_Ch3 is -- with the aliased entity (otherwise we generate a duplicated -- error message). - and then not Present (Interface_Alias (Subp)) + and then No (Interface_Alias (Subp)) then if Present (Alias_Subp) then @@ -14541,7 +14541,7 @@ package body Sem_Ch3 is -- in various places for an Empty upper bound, and in any case it -- accurately characterizes the index's range of values. - if Nkind (S) = N_Range and then not Present (High_Bound (S)) then + if Nkind (S) = N_Range and then No (High_Bound (S)) then Is_FLB_Index := True; Set_High_Bound (S, Type_High_Bound (T)); end if; @@ -16784,7 +16784,7 @@ package body Sem_Ch3 is -- have such primitives. if Present (Generic_Actual) - and then not Present (Act_Subp) + and then No (Act_Subp) and then Is_Limited_Interface (Parent_Base) and then Is_Predefined_Interface_Primitive (Subp) then diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 6824941..f136e97 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -5423,7 +5423,8 @@ package body Sem_Ch4 is -- untagged record types. if Ada_Version >= Ada_2005 - and then (Is_Tagged_Type (Prefix_Type) or else Extensions_Allowed) + and then (Is_Tagged_Type (Prefix_Type) + or else Core_Extensions_Allowed) and then not Is_Concurrent_Type (Prefix_Type) then if Nkind (Parent (N)) = N_Generic_Association @@ -5499,7 +5500,7 @@ package body Sem_Ch4 is -- Extension feature: Also support calls with prefixed views for -- untagged private types. - if Extensions_Allowed then + if Core_Extensions_Allowed then if Try_Object_Operation (N) then return; end if; @@ -5760,7 +5761,7 @@ package body Sem_Ch4 is -- Extension feature: Also support calls with prefixed views for -- untagged types. - elsif Extensions_Allowed + elsif Core_Extensions_Allowed and then Try_Object_Operation (N) then return; @@ -9862,7 +9863,7 @@ package body Sem_Ch4 is if (not Is_Tagged_Type (Obj_Type) and then - (not (Extensions_Allowed or Allow_Extensions) + (not (Core_Extensions_Allowed or Allow_Extensions) or else not Present (Primitive_Operations (Obj_Type)))) or else Is_Incomplete_Type (Obj_Type) then @@ -9891,7 +9892,7 @@ package body Sem_Ch4 is -- have homographic prefixed-view operations that could result -- in an ambiguity, but handling properly may be tricky. ???) - if (Extensions_Allowed or Allow_Extensions) + if (Core_Extensions_Allowed or Allow_Extensions) and then not Prim_Result and then Is_Named_Access_Type (Prev_Obj_Type) and then Present (Direct_Primitive_Operations (Prev_Obj_Type)) diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index d0f00b3..5f0629d 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1042,8 +1042,7 @@ package body Sem_Ch5 is if Ekind (Comp_Id) = E_Component and then Nkind (Parent (Comp_Id)) = N_Component_Declaration - and then - not Present (Expression (Parent (Comp_Id))) + and then No (Expression (Parent (Comp_Id))) then return True; end if; @@ -1614,7 +1613,7 @@ package body Sem_Ch5 is -- out non-discretes may resolve the ambiguity. -- But GNAT extensions allow casing on non-discretes. - elsif Extensions_Allowed and then Is_Overloaded (Exp) then + elsif Core_Extensions_Allowed and then Is_Overloaded (Exp) then -- It would be nice if we could generate all the right error -- messages by calling "Resolve (Exp, Any_Type);" in the @@ -1632,7 +1631,7 @@ package body Sem_Ch5 is -- Check for a GNAT-extension "general" case statement (i.e., one where -- the type of the selecting expression is not discrete). - elsif Extensions_Allowed + elsif Core_Extensions_Allowed and then not Is_Discrete_Type (Etype (Exp)) then Resolve (Exp, Etype (Exp)); @@ -1670,7 +1669,7 @@ package body Sem_Ch5 is ("(Ada 83) case expression cannot be of a generic type", Exp); return; - elsif not Extensions_Allowed + elsif not Core_Extensions_Allowed and then not Is_Discrete_Type (Exp_Type) then Error_Msg_N diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7ad6408..d28de10 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -264,7 +264,7 @@ package body Sem_Ch6 is elsif Warn_On_Redundant_Constructs and then not Is_Dispatching_Operation (Subp_Id) - and then not Present (Overridden_Operation (Subp_Id)) + and then No (Overridden_Operation (Subp_Id)) and then (not Is_Operator_Symbol_Name (Chars (Subp_Id)) or else Scop /= Scope (Etype (First_Formal (Subp_Id)))) then @@ -4070,7 +4070,7 @@ package body Sem_Ch6 is -- an instance that may have manipulated the flag during -- expansion. As a result, we add an exception for this case. - elsif not Present (Overridden_Operation (Spec_Id)) + elsif No (Overridden_Operation (Spec_Id)) and then not (Chars (Spec_Id) in Name_Adjust | Name_Finalize | Name_Initialize @@ -6795,7 +6795,7 @@ package body Sem_Ch6 is Error_Msg_Sloc := Sloc (Op); if Comes_From_Source (Op) or else No (Alias (Op)) then - if not Present (Overridden_Operation (Op)) then + if No (Overridden_Operation (Op)) then Error_Msg_N ("\\primitive % defined #", Typ); else Error_Msg_N @@ -8366,7 +8366,7 @@ package body Sem_Ch6 is or else not Is_Overloadable (Subp) or else not Is_Primitive (Subp) or else not Is_Dispatching_Operation (Subp) - or else not Present (Find_Dispatching_Type (Subp)) + or else No (Find_Dispatching_Type (Subp)) or else not Is_Interface (Find_Dispatching_Type (Subp)) then null; @@ -10711,13 +10711,13 @@ package body Sem_Ch6 is E : Entity_Id; begin - E := First_Entity (Prim); + E := First_Formal (Prim); while Present (E) loop - if Is_Formal (E) and then Is_Controlling_Formal (E) then + if Is_Controlling_Formal (E) then return E; end if; - Next_Entity (E); + Next_Formal (E); end loop; return Empty; @@ -11389,7 +11389,7 @@ package body Sem_Ch6 is return False; end if; - if not Present (Partial_View) then + if No (Partial_View) then return True; end if; @@ -11403,7 +11403,7 @@ package body Sem_Ch6 is begin loop H := Homonym (H); - exit when not Present (H) or else Scope (H) /= Scope (S); + exit when No (H) or else Scope (H) /= Scope (S); if Nkind (Parent (H)) in N_Private_Extension_Declaration | @@ -11451,7 +11451,7 @@ package body Sem_Ch6 is if ((Present (Partial_View) and then Is_Tagged_Type (Partial_View)) - or else (not Present (Partial_View) + or else (No (Partial_View) and then Is_Tagged_Type (T))) and then T = Base_Type (Etype (S)) then @@ -12947,7 +12947,7 @@ package body Sem_Ch6 is -- No need to continue if we already notified errors - if not Present (Formal_Type) then + if No (Formal_Type) then return; end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 5c347bd..77d1b38 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1317,11 +1317,10 @@ package body Sem_Ch7 is -- private_with_clauses, and remove them at the end of the nested -- package. - procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); - -- Clears constant indications (Never_Set_In_Source, Constant_Value, and - -- Is_True_Constant) on all variables that are entities of Id, and on - -- the chain whose first element is FE. A recursive call is made for all - -- packages and generic packages. + procedure Clear_Constants (Id : Entity_Id); + -- Clears constant indications (Never_Set_In_Source, Constant_Value, + -- and Is_True_Constant) on all variables that are entities of Id. + -- A recursive call is made for all packages and generic packages. procedure Generate_Parent_References; -- For a child unit, generate references to parent units, for @@ -1352,7 +1351,7 @@ package body Sem_Ch7 is -- Clear_Constants -- --------------------- - procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is + procedure Clear_Constants (Id : Entity_Id) is E : Entity_Id; begin @@ -1368,9 +1367,9 @@ package body Sem_Ch7 is -- package can contain a renaming declaration to itself, and such -- renamings are generated automatically within package instances. - E := FE; + E := First_Entity (Id); while Present (E) and then E /= Id loop - if Is_Assignable (E) then + if Ekind (E) = E_Variable then Set_Never_Set_In_Source (E, False); Set_Is_True_Constant (E, False); Set_Current_Value (E, Empty); @@ -1382,8 +1381,7 @@ package body Sem_Ch7 is end if; elsif Is_Package_Or_Generic_Package (E) then - Clear_Constants (E, First_Entity (E)); - Clear_Constants (E, First_Private_Entity (E)); + Clear_Constants (E); end if; Next_Entity (E); @@ -2009,8 +2007,7 @@ package body Sem_Ch7 is if Is_Library_Level_Entity (Id) or else Is_Generic_Instance (Id) then - Clear_Constants (Id, First_Entity (Id)); - Clear_Constants (Id, First_Private_Entity (Id)); + Clear_Constants (Id); end if; -- Output relevant information as to why the package requires a body. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index eb9e359..62b9cc0 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -960,7 +960,7 @@ package body Sem_Ch8 is Set_Etype (Nam, T); end if; elsif Present (Subtype_Mark (N)) - or else not Present (Access_Definition (N)) + or else No (Access_Definition (N)) then if Present (Subtype_Mark (N)) then Find_Type (Subtype_Mark (N)); @@ -4702,7 +4702,7 @@ package body Sem_Ch8 is -- want to deal with AST_Handler in ZFP mode. if not Configurable_Run_Time_Mode - and then not Present (Corresponding_Formal_Spec (N)) + and then No (Corresponding_Formal_Spec (N)) and then not Is_RTE (Etype (Nam), RE_AST_Handler) then declare @@ -7918,7 +7918,7 @@ package body Sem_Ch8 is if Is_Type (P_Type) and then (Has_Components (P_Type) - or else (Extensions_Allowed + or else (Core_Extensions_Allowed and then not Is_Concurrent_Type (P_Type))) and then not Is_Overloadable (P_Name) and then not Is_Type (P_Name) @@ -8173,7 +8173,7 @@ package body Sem_Ch8 is ("prefixed call is only allowed for objects of a " & "tagged type unless -gnatX is used", N); - if not Extensions_Allowed + if not Core_Extensions_Allowed and then Try_Object_Operation (N, Allow_Extensions => True) then @@ -9272,9 +9272,9 @@ package body Sem_Ch8 is Scope1 := Scope (Scope1); Scope2 := Scope (Scope2); - if not Present (Scope1) then + if No (Scope1) then return Clause1; - elsif not Present (Scope2) then + elsif No (Scope2) then return Clause2; end if; end loop; @@ -9717,10 +9717,10 @@ package body Sem_Ch8 is -- we saved (we use Remove, since this list will not be used again). loop - Elmt := Last_Elmt (List); + Elmt := First_Elmt (List); exit when Elmt = No_Elmt; Set_Is_Immediately_Visible (Node (Elmt)); - Remove_Last_Elmt (List); + Remove_Elmt (List, Elmt); end loop; -- Restore use clauses diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index f2a5901..e43e3ae 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -463,7 +463,7 @@ package body Sem_Ch9 is -- References - elsif Kind = N_Identifier + elsif Kind in N_Identifier | N_Expanded_Name and then Present (Entity (N)) then declare @@ -474,6 +474,12 @@ package body Sem_Ch9 is begin -- Prohibit references to non-constant entities -- outside the protected subprogram scope. + -- + -- References to variables in System.Scalar_Values + -- generated because of pragma Initialize_Scalars are + -- allowed, because once those variables are + -- initialized by the binder-generated code, they + -- behave like constants. if Is_Assignable (Id) and then not @@ -482,6 +488,9 @@ package body Sem_Ch9 is Scope_Within_Or_Same (Scope (Id), Protected_Body_Subprogram (Sub_Id)) + and then not + (Is_RTU (Scope (Id), System_Scalar_Values) + and then not Comes_From_Source (N)) then if Lock_Free_Given then Error_Msg_NE @@ -564,7 +573,7 @@ package body Sem_Ch9 is -- reference only one component of the protected type, plus -- the type of the component must support atomic operation. - if Kind = N_Identifier + if Kind in N_Identifier | N_Expanded_Name and then Present (Entity (N)) then declare diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index a24b9d7..801339a 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1316,7 +1316,7 @@ package body Sem_Dim is -- Look at the named components right after the positional components - if not Present (Next (Comp)) + if No (Next (Comp)) and then List_Containing (Comp) = Exps then Comp := First (Comp_Ass); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index ee1d96e..af26013 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -3072,18 +3072,27 @@ package body Sem_Disp is if Tagged_Type_Expansion then declare - Call_Typ : constant Entity_Id := Etype (Call_Node); + Call_Typ : Entity_Id := Etype (Call_Node); + Ctrl_Typ : Entity_Id := Etype (Control); begin Expand_Dispatching_Call (Call_Node); + if Is_Class_Wide_Type (Call_Typ) then + Call_Typ := Root_Type (Call_Typ); + end if; + + if Is_Class_Wide_Type (Ctrl_Typ) then + Ctrl_Typ := Root_Type (Ctrl_Typ); + end if; + -- If the controlling argument is an interface type and the type -- of Call_Node differs then we must add an implicit conversion to -- force displacement of the pointer to the object to reference -- the secondary dispatch table of the interface. - if Is_Interface (Etype (Control)) - and then Etype (Control) /= Call_Typ + if Is_Interface (Ctrl_Typ) + and then Ctrl_Typ /= Call_Typ then -- Cannot use Convert_To because the previous call to -- Expand_Dispatching_Call leaves decorated the Call_Node diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 2ba4608..195f27e 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -2856,10 +2856,11 @@ package body Sem_Eval is return; end if; - -- Intrinsic calls as part of a static function is a language extension. + -- Intrinsic calls as part of a static function is a (core) + -- language extension. if Checking_Potentially_Static_Expression - and then not Extensions_Allowed + and then not Core_Extensions_Allowed then return; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f85d091..60ea681 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -15408,12 +15408,12 @@ package body Sem_Prag is -- aspect/pragma from parent types (see Build_DIC_Procedure_Body), -- though that extra argument isn't documented for the pragma. - if not Present (Arg2) then + if No (Arg2) then -- When the pragma has no arguments, create an argument with -- the value Empty, so the type name argument can be appended -- following it (since it's expected as the second argument). - if not Present (Arg1) then + if No (Arg1) then Set_Pragma_Argument_Associations (N, New_List ( Make_Pragma_Argument_Association (Sloc (Typ), Expression => Empty))); @@ -16595,16 +16595,18 @@ package body Sem_Prag is -- Extensions_Allowed -- ------------------------ - -- pragma Extensions_Allowed (ON | OFF); + -- pragma Extensions_Allowed (ON | OFF | ALL); when Pragma_Extensions_Allowed => GNAT_Pragma; Check_Arg_Count (1); Check_No_Identifiers; - Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off, Name_All); if Chars (Get_Pragma_Arg (Arg1)) = Name_On then - Ada_Version := Ada_With_Extensions; + Ada_Version := Ada_With_Core_Extensions; + elsif Chars (Get_Pragma_Arg (Arg1)) = Name_All then + Ada_Version := Ada_With_All_Extensions; else Ada_Version := Ada_Version_Explicit; Ada_Version_Pragma := Empty; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 25e886e..5c49576 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -651,7 +651,7 @@ package body Sem_Util is -- been generated when one should have ??? elsif Is_Formal (E) - and then not Present (Get_Dynamic_Accessibility (E)) + and then No (Get_Dynamic_Accessibility (E)) and then Ekind (Etype (E)) = E_Anonymous_Access_Type then return Make_Level_Literal (Scope_Depth (Standard_Standard)); @@ -1044,7 +1044,11 @@ package body Sem_Util is -- Add_Block_Identifier -- -------------------------- - procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is + procedure Add_Block_Identifier + (N : Node_Id; + Id : out Entity_Id; + Scope : Entity_Id := Current_Scope) + is Loc : constant Source_Ptr := Sloc (N); begin pragma Assert (Nkind (N) = N_Block_Statement); @@ -1057,7 +1061,7 @@ package body Sem_Util is -- Create a new block label and set its attributes else - Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); + Id := New_Internal_Entity (E_Block, Scope, Loc, 'B'); Set_Etype (Id, Standard_Void_Type); Set_Parent (Id, N); @@ -1335,7 +1339,7 @@ package body Sem_Util is end if; return - not Present (Etype (Constr)) -- previous error + No (Etype (Constr)) -- previous error or else not Is_Discrete_Type (Etype (Constr)) or else Is_OK_Static_Expression (Constr); @@ -3195,7 +3199,7 @@ package body Sem_Util is Actual : Node_Id; begin - if Extensions_Allowed then + if All_Extensions_Allowed then Actual := First_Actual (Call); while Present (Actual) loop if Nkind (Actual) = N_Aggregate then @@ -4449,7 +4453,7 @@ package body Sem_Util is pragma Assert (Present (Ifc_Ancestors (Idx))); Ifc := Next (Ifc); end loop; - pragma Assert (not Present (Ifc)); + pragma Assert (No (Ifc)); if Present (Parent_Type) then return Parent_Type & Ifc_Ancestors; else @@ -7045,7 +7049,6 @@ package body Sem_Util is if Present (Asp) then Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp))); - Set_Has_Aspects (To, True); end if; end if; end Copy_Ghost_Aspect; @@ -7097,7 +7100,6 @@ package body Sem_Util is if Present (Asp) then Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp))); - Set_Has_Aspects (To, True); end if; end if; end Copy_SPARK_Mode_Aspect; @@ -11573,7 +11575,7 @@ package body Sem_Util is -- entry families with no Max_Queue_Length aspect or pragma default to -- it. - if not Present (Prag) then + if No (Prag) then return Uint_0; end if; @@ -13092,7 +13094,7 @@ package body Sem_Util is Typ := Corresponding_Record_Type (Typ); end if; - if not Present (Typ) + if No (Typ) or else not Is_Record_Type (Typ) or else not Is_Tagged_Type (Typ) then @@ -13675,15 +13677,12 @@ package body Sem_Util is Exp : Node_Id; begin - -- Loop through entities of record or protected type + -- Loop through components and discriminants of record or protected + -- type. - Ent := E; + Ent := First_Component_Or_Discriminant (E); while Present (Ent) loop - -- We are interested only in components and discriminants - - Exp := Empty; - case Ekind (Ent) is when E_Component => @@ -13694,6 +13693,8 @@ package body Sem_Util is if Present (Declaration_Node (Ent)) then Exp := Expression (Declaration_Node (Ent)); + else + Exp := Empty; end if; when E_Discriminant => @@ -13706,7 +13707,7 @@ package body Sem_Util is Exp := Discriminant_Default_Value (Ent); when others => - goto Check_Next_Entity; + raise Program_Error; end case; -- A component has PI if it has no default expression and the @@ -13727,8 +13728,7 @@ package body Sem_Util is exit; end if; - <<Check_Next_Entity>> - Next_Entity (Ent); + Next_Component_Or_Discriminant (Ent); end loop; end Check_Components; @@ -13838,7 +13838,7 @@ package body Sem_Util is -- If OK, check extension components (if any) if Has_PE and then Is_Record_Type (E) then - Check_Components (First_Entity (E)); + Check_Components (E); end if; -- Check specifically for 10.2.1(11.4/2) exception: a controlled type @@ -13878,7 +13878,7 @@ package body Sem_Util is elsif Is_Record_Type (E) then Has_PE := True; - Check_Components (First_Entity (E)); + Check_Components (E); -- Protected types must not have entries, and components must meet -- same set of rules as for record components. @@ -13888,8 +13888,7 @@ package body Sem_Util is Has_PE := False; else Has_PE := True; - Check_Components (First_Entity (E)); - Check_Components (First_Private_Entity (E)); + Check_Components (E); end if; -- Type System.Address always has preelaborable initialization @@ -14795,8 +14794,15 @@ package body Sem_Util is loop if No (P) then return False; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (P) then + return False; + elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then return True; + else P := Parent (P); end if; @@ -14872,6 +14878,12 @@ package body Sem_Util is loop if No (P) then return False; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (P) then + return False; + elsif Nkind (P) = N_Quantified_Expression then return True; else @@ -18301,7 +18313,7 @@ package body Sem_Util is Is_Object (Id) and then (Is_Independent (Id) or else - Is_Independent (Etype (Id))); + Is_Independent (Etype (Id))); end Is_Independent_Object_Entity; ------------------------------------- @@ -19458,7 +19470,7 @@ package body Sem_Util is return True; elsif Present (Variant_Part (Component_List (Record_Def))) then return False; - elsif not Present (Component_List (Record_Def)) then + elsif No (Component_List (Record_Def)) then return True; end if; @@ -22287,25 +22299,6 @@ package body Sem_Util is procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is S : Entity_Id; - procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); - -- Clear current value for entity E and all entities chained to E - - ------------------------------------------ - -- Kill_Current_Values_For_Entity_Chain -- - ------------------------------------------ - - procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is - Ent : Entity_Id; - begin - Ent := E; - while Present (Ent) loop - Kill_Current_Values (Ent, Last_Assignment_Only); - Next_Entity (Ent); - end loop; - end Kill_Current_Values_For_Entity_Chain; - - -- Start of processing for Kill_Current_Values - begin -- Kill all saved checks, a special case of killing saved values @@ -22321,16 +22314,15 @@ package body Sem_Util is -- Clear current values of all entities in current scope - Kill_Current_Values_For_Entity_Chain (First_Entity (S)); - - -- If scope is a package, also clear current values of all private - -- entities in the scope. - - if Is_Package_Or_Generic_Package (S) - or else Is_Concurrent_Type (S) - then - Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); - end if; + declare + Ent : Entity_Id; + begin + Ent := First_Entity (S); + while Present (Ent) loop + Kill_Current_Values (Ent, Last_Assignment_Only); + Next_Entity (Ent); + end loop; + end; -- If this is a not a subprogram, deal with parents @@ -31575,7 +31567,7 @@ package body Sem_Util is Next (Range_Or_Expr); end loop; - pragma Assert (not Present (Range_Or_Expr)); + pragma Assert (No (Range_Or_Expr)); Check_Consistency (Result); return Result; end; @@ -31825,7 +31817,7 @@ package body Sem_Util is and then Is_Non_Empty_List (Alternatives (Par)) and then Trailer /= First (Alternatives (Par)) then - pragma Assert (not Present (Right_Opnd (Par))); + pragma Assert (No (Right_Opnd (Par))); pragma Assert (Is_List_Member (Trailer) and then List_Containing (Trailer) diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c23d358..88bfbfc 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -88,11 +88,6 @@ package Sem_Util is -- Add A to the list of access types to process when expanding the -- freeze node of E. - procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id); - -- Given a block statement N, generate an internal E_Block label and make - -- it the identifier of the block. Id denotes the generated entity. If the - -- block already has an identifier, Id returns the entity of its label. - procedure Add_Global_Declaration (N : Node_Id); -- These procedures adds a declaration N at the library level, to be -- elaborated before any other code in the unit. It is used for example @@ -678,6 +673,15 @@ package Sem_Util is function Current_Scope return Entity_Id; -- Get entity representing current scope + procedure Add_Block_Identifier + (N : Node_Id; + Id : out Entity_Id; + Scope : Entity_Id := Current_Scope); + -- Given a block statement N, generate an internal E_Block label and make + -- it the identifier of the block. Scope denotes the scope in which the + -- generated entity Id is created and defaults to the current scope. If the + -- block already has an identifier, Id returns the entity of its label. + function Current_Scope_No_Loops return Entity_Id; -- Return the current scope ignoring internally generated loops diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 1d73f21..77d5821 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -928,7 +928,7 @@ package body Sem_Warn is if not Is_Generic_Type (T) then null; - elsif (Nkind (Par)) = N_Private_Extension_Declaration then + elsif Nkind (Par) = N_Private_Extension_Declaration then -- We only indicate the first such variable in the generic. @@ -936,7 +936,7 @@ package body Sem_Warn is Set_Uninitialized_Variable (Par, Ent); end if; - elsif (Nkind (Par)) = N_Formal_Type_Declaration + elsif Nkind (Par) = N_Formal_Type_Declaration and then Nkind (Formal_Type_Definition (Par)) = N_Formal_Private_Type_Definition then @@ -1151,8 +1151,6 @@ package body Sem_Warn is E1 := First_Entity (E); while Present (E1) loop - E1T := Etype (E1); - -- We are only interested in source entities. We also don't issue -- warnings within instances, since the proper place for such -- warnings is on the template when it is compiled, and we don't @@ -1161,6 +1159,8 @@ package body Sem_Warn is if Comes_From_Source (E1) and then Instantiation_Location (Sloc (E1)) = No_Location then + E1T := Etype (E1); + -- We are interested in variables and out/in-out parameters, but -- we exclude protected types, too complicated to worry about. @@ -1221,7 +1221,7 @@ package body Sem_Warn is elsif Warn_On_Constant and then Ekind (E1) = E_Variable and then Has_Initial_Value (E1) - and then Never_Set_In_Source_Check_Spec (E1) + and then Never_Set_In_Source (E1) and then not Generic_Package_Spec_Entity (E1) then -- A special case, if this variable is volatile and not @@ -1248,24 +1248,15 @@ package body Sem_Warn is -- Here we give the warning if referenced and no pragma -- Unreferenced or Unmodified is present. - else - -- Variable case - - if Ekind (E1) = E_Variable then - if Referenced_Check_Spec (E1) - and then not Has_Pragma_Unreferenced_Check_Spec (E1) - and then not Has_Pragma_Unmodified_Check_Spec (E1) - then - if not Warnings_Off_E1 - and then not Has_Junk_Name (E1) - then - Error_Msg_N -- CODEFIX - ("?k?& is not modified, " - & "could be declared constant!", - E1); - end if; - end if; - end if; + elsif Referenced (E1) + and then not Has_Unreferenced (E1) + and then not Has_Unmodified (E1) + and then not Warnings_Off_E1 + and then not Has_Junk_Name (E1) + then + Error_Msg_N -- CODEFIX + ("?k?& is not modified, could be declared constant!", + E1); end if; -- Other cases of a variable or parameter never set in source @@ -1648,20 +1639,6 @@ package body Sem_Warn is not Is_Package_Or_Generic_Package (Cunit_Entity (Current_Sem_Unit)))) - -- Exclude instantiations, since there is no reason why every - -- entity in an instantiation should be referenced. - - and then Instantiation_Location (Sloc (E1)) = No_Location - - -- Exclude formal parameters from bodies if the corresponding - -- spec entity has been referenced in the case where there is - -- a separate spec. - - and then not (Is_Formal (E1) - and then Ekind (Scope (E1)) = E_Subprogram_Body - and then Present (Spec_Entity (E1)) - and then Referenced (Spec_Entity (E1))) - -- Consider private type referenced if full view is referenced. -- If there is not full view, this is a generic type on which -- warnings are also useful. @@ -2001,8 +1978,7 @@ package body Sem_Warn is P := Parent (Nod); if Nkind (P) = N_Pragma - and then Pragma_Name (P) = - Name_Test_Case + and then Pragma_Name (P) = Name_Test_Case and then Nod = Test_Case_Arg (P, Name_Ensures) then return True; @@ -3028,7 +3004,7 @@ package body Sem_Warn is -- if we have seen the address of the subprogram being taken, or if the -- subprogram is used as a generic actual (in the latter cases the -- context may force use of IN OUT, even if the parameter is not - -- modified for this particular case. + -- modified for this particular case). ----------------------- -- No_Warn_On_In_Out -- @@ -4282,7 +4258,7 @@ package body Sem_Warn is if Ekind (Form) = E_Out_Parameter and then Never_Set_In_Source_Check_Spec (Form) and then Is_Scalar_Type (Etype (Form)) - and then not Present (Unset_Reference (Form)) + and then No (Unset_Reference (Form)) then -- Here all conditions are met, record possible unset reference diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 53880c5..c41b0f2 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -440,7 +440,7 @@ package Sinfo is -- documents the restriction. -- Note that most of these restrictions apply only to trees generated when - -- code is being generated, since they involved expander actions that + -- code is being generated, since they involve expander actions that -- destroy the tree. ---------------- @@ -528,7 +528,7 @@ package Sinfo is -- function. -- -- If the mode of a Ghost region is Ignore, any newly created nodes as well - -- as source entities are marked as ignored Ghost. In additon, the marking + -- as source entities are marked as ignored Ghost. In addition, the marking -- process signals all enclosing scopes that an ignored Ghost node resides -- within. The compilation unit where the node resides is also added to an -- auxiliary table for post processing. @@ -629,7 +629,7 @@ package Sinfo is -- specified by means of an aspect or a pragma. -- The following entities may be subject to a SPARK mode. Entities marked - -- with * may possess two differente SPARK modes. + -- with * may possess two different SPARK modes. -- E_Entry -- E_Entry_Family @@ -715,9 +715,9 @@ package Sinfo is -- This flag is set if the node comes directly from an explicit construct -- in the source. It is normally on for any nodes built by the scanner or -- parser from the source program, with the exception that in a few cases - -- the parser adds nodes to normalize the representation (in particular + -- the parser adds nodes to normalize the representation (in particular, -- a null statement is added to a package body if there is no begin/end - -- initialization section. + -- initialization section). -- -- Most nodes inserted by the analyzer or expander are not considered -- as coming from source, so the flag is off for such nodes. In a few @@ -1549,7 +1549,7 @@ package Sinfo is -- Is_Analyzed_Pragma -- Present in N_Pragma nodes. Set for delayed pragmas that require a two - -- step analysis. The initial step is peformed by routine Analyze_Pragma + -- step analysis. The initial step is performed by routine Analyze_Pragma -- and verifies the overall legality of the pragma. The second step takes -- place in the various Analyze_xxx_In_Decl_Part routines which perform -- full analysis. The flag prevents the reanalysis of a delayed pragma. @@ -1641,8 +1641,9 @@ package Sinfo is -- variable reference marker -- -- Set when the node appears within a context which allows the generation - -- of run-time ABE checks. This flag detemines whether the ABE Processing - -- phase generates conditional ABE checks and guaranteed ABE failures. + -- of run-time ABE checks. This flag determines whether the ABE + -- Processing phase generates conditional ABE checks and guaranteed ABE + -- failures. -- Is_Elaboration_Code -- Present in assignment statements. Set for an assignment which updates @@ -5570,7 +5571,7 @@ package Sinfo is -- The term "return statement" is defined in 6.5 to mean either a -- SIMPLE_RETURN_STATEMENT or an EXTENDED_RETURN_STATEMENT. We avoid - -- the use of this term, since it used to mean someting else in earlier + -- the use of this term, since it used to mean something else in earlier -- versions of Ada. -- N_Simple_Return_Statement @@ -7815,7 +7816,7 @@ package Sinfo is -- ABE mechanism, regardless of whether expansion took place. -- * The call marker captures the target of the related call along - -- with other attributes which are either unavailabe or expensive + -- with other attributes which are either unavailable or expensive -- to recompute once analysis, resolution, and expansion are over. -- * The call marker aids the ABE Processing phase by signaling the diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index feac8bd..a1a8777 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -1391,12 +1391,21 @@ package body Switch.C is Ptr := Ptr + 1; Xref_Active := False; - -- -gnatX (language extensions) + -- -gnatX (core language extensions) when 'X' => Ptr := Ptr + 1; - Ada_Version := Ada_With_Extensions; - Ada_Version_Explicit := Ada_With_Extensions; + + if Ptr <= Max and then Switch_Chars (Ptr) = '0' then + -- -gnatX0 (all language extensions) + + Ptr := Ptr + 1; + Ada_Version := Ada_With_All_Extensions; + else + Ada_Version := Ada_With_Core_Extensions; + end if; + + Ada_Version_Explicit := Ada_Version; Ada_Version_Pragma := Empty; -- -gnaty (style checks) |