diff options
| author | Ian Lance Taylor <iant@golang.org> | 2020-10-12 09:46:38 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2020-10-12 09:46:38 -0700 |
| commit | 9cd320ea6572c577cdf17ce1f9ea5230b166af6d (patch) | |
| tree | d1c8e7c2e09a91ed75f0e5476c648c2e745aa2de /gcc/ada | |
| parent | 4854d721be78358e59367982bdd94461b4be3c5a (diff) | |
| parent | 3175d40fc52fb8eb3c3b18cc343d773da24434fb (diff) | |
| download | gcc-9cd320ea6572c577cdf17ce1f9ea5230b166af6d.zip gcc-9cd320ea6572c577cdf17ce1f9ea5230b166af6d.tar.gz gcc-9cd320ea6572c577cdf17ce1f9ea5230b166af6d.tar.bz2 | |
Merge from trunk revision 3175d40fc52fb8eb3c3b18cc343d773da24434fb.
Diffstat (limited to 'gcc/ada')
241 files changed, 8655 insertions, 10063 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6e4b0e3..98e0f45 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,859 @@ +2020-10-11 Alexandre Oliva <oliva@adacore.com> + + * libgnat/a-numaux.ads: Make all imports Intrinsic. + * libgnat/a-numaux__darwin.ads: Likewise. + * libgnat/a-numaux__libc-x86.ads: Likewise. + * libgnat/a-numaux__vxworks.ads: Likewise. + +2020-09-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Set the end locus + of body and declaration earlier. + +2020-09-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (maybe_saturate_size): Add ALIGN parameter + and round down the result to ALIGN. + (gnat_to_gnu_entity): Adjust calls to maybe_saturate_size. + +2020-09-14 Jakub Jelinek <jakub@redhat.com> + + * gcc-interface/trans.c (gigi): Adjust build_optimization_node + caller. + +2020-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * fe.h: Fix pilot error in previous change. + * gcc-interface/gigi.h (enum standard_datatypes): Add ADT_mulv128_decl. + (mulv128_decl): New macro. + (get_target_long_long_long_size): Declare. + * gcc-interface/decl.c (gnat_to_gnu_entity): Use a maximum size of + 128 bits for discrete types if Enable_128bit_Types is true. + * gcc-interface/targtyps.c: Include target.h. + (get_target_long_long_long_size): New function. + * gcc-interface/trans.c (gigi): Initialize mulv128_decl if need be. + (build_binary_op_trapv): Call it for 128-bit multiplication. + * gcc-interface/utils.c (make_type_from_size): Enforce a maximum + size of 128 bits if Enable_128bit_Types is true. + +2020-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (lvalue_for_aggr_p) <N_Object_Declaration>: + Return false unconditionally. + +2020-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (gnat_to_gnu) <N_Object_Declaration>: Clear + the SLOC of the expression of a tag. + +2020-09-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Only give + a warning for the overlay of an aliased array with an unconstrained + nominal subtype if the address is absolute. + +2020-09-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (type_has_variable_size): New function. + (create_field_decl): In the packed case, also force byte alignment + when the type of the field has variable size. + +2020-09-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/misc.c (get_array_bit_stride): Return TYPE_ADA_SIZE + for record and union types. + +2020-09-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/misc.c (gnat_get_fixed_point_type): Bail out only + when the GNAT encodings are specifically used. + +2020-09-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Subtype>: Only + create extra subtypes for discriminants if the RM size of the base + type of the index type is lower than that of the index type. + +2020-09-10 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (set_rm_size): Do not take into account the + Value_Size clause if it is not for the entity itself. + +2020-09-10 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (build_subst_list): For a definition, make + sure to instantiate the SAVE_EXPRs generated by the elaboration of + the constraints in front of the elaboration of the type itself. + +2020-09-10 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/misc.c: Include tree-pass.h. + (internal_error_function): Call emergency_dump_function. + +2020-09-03 Arnaud Charlet <charlet@adacore.com> + + * fe.h, opt.ads (Enable_128bit_Types): New. + * stand.ads (Standard_Long_Long_Long_Integer, + S_Long_Long_Long_Integer): New. + +2020-09-03 Arnaud Charlet <charlet@adacore.com> + + * sem_util.ads, sem_util.adb (Get_Fullest_View): New procedure. + * exp_unst.adb (Check Static_Type): Do all processing on fullest + view of specified type. + +2020-08-27 Martin Liska <mliska@suse.cz> + + * gcc-interface/trans.c (gigi): Set exact argument of a vector + growth function to true. + (Attribute_to_gnu): Likewise. + +2020-07-27 Alexandre Oliva <oliva@adacore.com> + + * switch.adb (Is_Internal_GCC_Switch): Revert accidental + reintroduction of auxbase and auxbase-strip. + +2020-07-27 Javier Miranda <miranda@adacore.com> + + * sem_res.adb (Resolve_Actuals): Restrict the check on matching + aliased components to view conversions of array types that are + not placed in an instance. In such case at runtime an object is + created. + * sem_util.ads (Is_Actual_In_Out_Parameter, Is_View_Conversion): + New subprograms. + * sem_util.adb (Is_Actual_In_Out_Parameter, Is_View_Conversion): + New subprograms. + +2020-07-27 Arnaud Charlet <charlet@adacore.com> + + * lib-xref.adb (Generate_Reference): Protect against malformed + tree in case of severe errors. + * sem_ch8.adb (Add_Implicit_Operator): Ditto. + +2020-07-27 Arnaud Charlet <charlet@adacore.com> + + * opt.ads (Ada_Version_Runtime): Set to Ada_2020. + * sem_ch3.adb (Analyze_Subtype_Declaration): Propagate + Is_Independent flag to subtypes. + * libgnarl/s-taprop__linux.adb: Adapt to Ada 2020 warning. + * libgnat/a-nbnbin.adb, libgnat/a-nbnbin.ads, + libgnat/a-nbnbin__gmp.adb, libgnat/a-nbnbre.adb, + libgnat/a-nbnbre.ads, libgnat/a-stobbu.adb, + libgnat/a-stobbu.ads, libgnat/a-stobfi.adb, + libgnat/a-stobfi.ads, libgnat/a-stoubu.adb, + libgnat/a-stoubu.ads, libgnat/a-stoufi.adb, + libgnat/a-stoufi.ads, libgnat/a-stoufo.adb, + libgnat/a-stoufo.ads, libgnat/a-stouut.adb, + libgnat/a-stouut.ads, libgnat/a-strsto.ads, + libgnat/a-ststbo.adb, libgnat/a-ststbo.ads, + libgnat/a-ststun.adb, libgnat/a-ststun.ads, + libgnat/a-stteou.ads, libgnat/s-aoinar.ads, + libgnat/s-aomoar.ads, libgnat/s-atopex.ads, + libgnat/s-putaim.adb, libgnat/s-putaim.ads, + libgnat/s-putima.adb, libgnat/s-putima.ads: Remove pragma + Ada_2020, now redundant. + +2020-07-27 Justin Squirek <squirek@adacore.com> + + * exp_ch6.adb (Expand_Call_Helper): Modify addition of the extra + accessibility parameter to take into account the extra + accessibility of formals within the calling subprogram. + +2020-07-27 Bob Duff <duff@adacore.com> + + * exp_imgv.adb (Expand_Image_Attribute): Add Root_Type, so + constrained subtypes work. + +2020-07-27 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_prag.adb (Arg1, Arg2, Arg3): Removed. + (Arg_N): New function. + +2020-07-27 Arnaud Charlet <charlet@adacore.com> + + * sem_ch8.adb (Analyze_Object_Renaming): Allow values in Ada + 2020 mode. + +2020-07-27 Arnaud Charlet <charlet@adacore.com> + + * sem_res.adb (Resolve_Actuals): Refine 6.4.1 rules as per + AI12-0377. + +2020-07-27 Bob Duff <duff@adacore.com> + + * errout.ads, errout.adb (Error_Msg_Ada_2020_Feature): New + procedure analogous to Error_Msg_Ada_2012_Feature. + * sem_attr.adb (Analyze_Image_Attribute): Use + Error_Msg_Ada_2012_Feature and Error_Msg_Ada_2020_Feature to + indicate that Object'Image is allowed in Ada 2012, and that + 'Image is allowed for any type in Ada 2020. + +2020-07-27 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/a-strunb.adb (Sum, Mul, Saturated_Sum, Saturated_Mul): + New routines. Use them when resulting string size more that + length of the strings in parameters. + (Unbounded_Slice): Use "- 1" instead of "+ 1" in opposite side + of condition to avoid overflow. + * libgnat/a-strunb__shared.adb (Sum, Mul): New routines. + (Allocate): New routine with 2 parameters. Use routine above + when resulting string size more that length of the strings in + parameters. + (Aligned_Max_Length): Do not try to align to more than Natural'Last. + (Unbounded_Slice): Use "- 1" instead of "+ 1" in opposite side + of condition to avoid overflow. + +2020-07-27 Arnaud Charlet <charlet@adacore.com> + + * sem_attr.adb (Resolve_Attribute): Remove dead code. + +2020-07-27 Arnaud Charlet <charlet@adacore.com> + + * aspects.adb, atree.adb, atree.ads, checks.adb, contracts.adb, + einfo.adb, errout.adb, exp_aggr.adb, exp_attr.adb, exp_cg.adb, + exp_ch11.adb, exp_ch2.adb, exp_ch3.adb, exp_ch4.adb, + exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch8.adb, exp_ch9.adb, + exp_dbug.adb, exp_disp.adb, exp_intr.adb, exp_pakd.adb, + exp_prag.adb, exp_put_image.adb, exp_smem.adb, exp_tss.adb, + exp_unst.adb, exp_util.adb, freeze.adb, ghost.adb, gnat1drv.adb, + inline.adb, lib-writ.adb, lib-xref-spark_specific.adb, + lib-xref.adb, namet.adb, namet.ads, nlists.adb, par-ch10.adb, + par-ch2.adb, par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb, + par-prag.adb, par-util.adb, par_sco.adb, pprint.adb, + repinfo.adb, restrict.adb, rtsfind.adb, scil_ll.adb, sem.adb, + sem_aggr.adb, sem_attr.adb, sem_aux.adb, sem_cat.adb, + sem_ch10.adb, sem_ch11.adb, sem_ch12.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch7.adb, + sem_ch8.adb, sem_ch9.adb, sem_dim.adb, sem_disp.adb, + sem_dist.adb, sem_elab.adb, sem_elim.adb, sem_eval.adb, + sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb, + sem_scil.adb, sem_type.adb, sem_util.adb, sem_warn.adb, + sinfo.adb, sinfo.ads, sprint.adb, styleg.adb, tbuild.adb, + treepr.adb (Nkind_In, Nam_In, Ekind_In): Removed, replaced by + membership tests. + +2020-07-27 Gary Dismukes <dismukes@adacore.com> + + * sem_prag.adb (Analyze_Pragma, Pragma_Max_Entry_Queue_Length): + Refine error message to indicate that the pragma must apply to + an entry declaration, not just an entry. + +2020-07-27 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Iface_Call_In_Allocator): + Revert previous patch, and add a missing type conversion to + displace the pointer to the allocated object to reference the + target dispatch table. + +2020-07-27 Javier Miranda <miranda@adacore.com> + + * sem_res.adb (Resolve_Actuals): Restore restrictive check on + view conversions which required matching value of + Has_Aliased_Components of formals and actuals. Required to avoid + the regression of ACATS b460005. + +2020-07-27 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Instantiate_Package_Body): Add commentary for a + nesting issue with parent handling and private view switching. + (Switch_View): Do not skip specific private-dependent subtypes. + +2020-07-27 Patrick Bernardi <bernardi@adacore.com> + + * Makefile.rtl: Remove X86_TARGET_PAIRS for x86-lynx178elf. + +2020-07-27 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Address_Specification_Clause): Do not + emit a warning when a constant declaration in a generic unit + overlays a generic In_Parameter. + +2020-07-27 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Check_Abstract_Overriding): Remove Scope + comparison test from test related to initial implementation of + AI12-0042, plus remove the related ??? comment. + (Derive_Subprogram): Add test requiring that the type extension + appear in the visible part of its enclosing package when + checking the overriding requirement of 7.3.2(6.1/4), as + clarified by AI12-0382. + +2020-07-27 Piotr Trojanek <trojanek@adacore.com> + + * exp_spark.adb (Expand_SPARK_N_Attribute_Reference) Extend + existing workaround to 'Pos. + +2020-07-27 Bob Duff <duff@adacore.com> + + * libgnat/s-rannum.ads, libgnat/s-rannum.adb: Add Put_Image. + This will be inherited by the language-defined packages + Ada.Numerics.Discrete_Random and Ada.Numerics.Float_Random. + * libgnat/a-convec.ads, libgnat/a-convec.adb: Add Put_Image. + * libgnat/s-putima.ads: Add pragma Preelaborate, so this can be + imported into containers packages. + * libgnat/s-putima.adb: Move Digit to private part; otherwise + reference to Base is illegal in Preelaborate generic. + * exp_put_image.adb (Build_Record_Put_Image_Procedure): Use the + base type. + +2020-07-23 Arnaud Charlet <charlet@adacore.com> + + * aspects.ads: Declare CUDA_Global as aspect. + * einfo.ads: Use Flag118 for the Is_CUDA_Kernel flag. + (Set_Is_CUDA_Kernel): New function. + (Is_CUDA_Kernel): New function. + * einfo.adb (Set_Is_CUDA_Kernel): New function. + (Is_CUDA_Kernel): New function. + * par-prag.adb (Prag): Ignore Pragma_CUDA_Execute and + Pragma_CUDA_global. + * rtsfind.ads: Define CUDA.Driver_Types.Stream_T and + CUDA.Vector_Types.Dim3 entities + * rtsfind.adb: Define CUDA_Descendant subtype. + (Get_Unit_Name): Handle CUDA_Descendant packages. + * sem_prag.ads: Mark CUDA_Global as aspect-specifying pragma. + * sem_prag.adb (Analyze_Pragma): Validate Pragma_CUDA_Execute and + Pragma_CUDA_Global. + * snames.ads-tmpl: Define Name_CUDA_Execute and Name_CUDA_Global. + +2020-07-23 Arnaud Charlet <charlet@adacore.com> + + * sem_ch13.ads (Same_Representation): Renamed as + Has_Compatible_Representation because now the order of the arguments + are taken into account; its formals are also renamed as Target_Type + and Operand_Type. + * sem_ch13.adb (Same_Representation): Renamed and moved to place the + routine in alphabetic order. + * sem_attr.adb (Prefix_With_Safe_Accessibility_Level): New subprogram. + (Resolve_Attribute): Check that the prefix of attribute Access + does not have a value conversion of an array type. + * sem_res.adb (Resolve_Actuals): Remove restrictive check on view + conversions which required matching value of Has_Aliased_Components of + formals and actuals. + * exp_ch4.adb (Handle_Changed_Representation): Update call to + Same_Representation. + (Expand_N_Type_Conversion): Update call to Same_Representation. + * exp_ch5.adb (Change_Of_Representation): Update call to + Same_Representation. + * exp_ch6.adb (Add_Call_By_Copy_Code): Update call to + Same_Representation. + (Expand_Actuals): Update call to Same_Representation. + (Expand_Call_Helper): Update call to Same_Representation. + +2020-07-23 Arnaud Charlet <charlet@adacore.com> + + * output.ads (Push_Output, Pop_Output): New procedures. + * output.adb (FD_Array, FD_Stack, FD_Stack_Idx): New type and vars. + (Push_Output, Pop_Output): New procedures. + +2020-07-16 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Expand_N_Full_Type_Declaration): Ensure a _master + declaration on limited types that might have tasks. + * exp_ch9.adb (Build_Master_Renaming): For private types, if we + are processing declarations in the private part, ensure that + master is inserted before its full declaration; otherwise the + master renaming may be inserted in the public part of the + package (and hence before the declaration of its _master + variable). + +2020-07-16 Arnaud Charlet <charlet@adacore.com> + + * sem_ch8.adb (Analyze_Subprogram_Renaming): A renames-as-body + freezes the expression of any expression function that it + renames. + +2020-07-16 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb (Resolve_Container_Aggregate): Add semantic + checks for indexed aggregates, including component associations + and iterated component associations. + * exp_aggr.adb (Expand_Iterated_Component): New subprogram, + subsidiary of Expand_Container_Aggreggate, used for positional, + named, and indexed aggregates. + (Aggregate_Size): New subprogram to precompute the size of an + indexed aggregate prior to call to allocate it. + (Expand_Range_Component): New subprogram so generate loop for a + component association given by a range or a subtype name in an + indexed aggregate. + +2020-07-16 Bob Duff <duff@adacore.com> + + * bindo-diagnostics.adb (Output_Invocation_Related_Suggestions): + Use Cumulative_Restrictions.Set, because Restriction_Active only + works at compile time. + +2020-07-16 Bob Duff <duff@adacore.com> + + * gnatbind.adb (Gnatbind): For No_Tasks_Unassigned_To_CPU, check + that CPU has been set on the main subprogram. + (Restriction_Could_Be_Set): Don't print + No_Tasks_Unassigned_To_CPU if it would violate the + above-mentioned rule. Up to now, all restrictions were checked + by the compiler, with the binder just checking for consistency. + But the compiler can't know which subprogram is the main, so + it's impossible to check this one at compile time. + * restrict.ads, restrict.adb: Misc refactoring. Change Warning + to Warn, for consistency, since most already use Warn. + (Set_Restriction): New convenience routine. + * sem_ch13.adb (Attribute_CPU): Check + No_Tasks_Unassigned_To_CPU. + * sem_prag.adb (Pragma_CPU): Check No_Tasks_Unassigned_To_CPU. + Misc refactoring. + * tbuild.ads, tbuild.adb (Sel_Comp): New functions for building + selected components. + +2020-07-16 Eric Botcazou <ebotcazou@adacore.com> + + * impunit.adb (Non_Imp_File_Names_95): Remove duplicate entry. + +2020-07-16 Arnaud Charlet <charlet@adacore.com> + + * Makefile.rtl: replace a-numaux__x86.ads by + a-numaux__libc-x86.ads and a-numaux__x86.adb by + a-numaux__dummy.adb. + * libgnat/a-numaux__x86.ads, libgnat/a-numaux__x86.adb: Removed. + * libgnat/a-numaux__dummy.adb: New. + +2020-07-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Load_Parent_Of_Generic): If an ancestor is an + instance whose source appears within a formal package of the + current unit, there is no body of the ancestor needed to + complete the current generic compilation. + +2020-07-16 Doug Rupp <rupp@adacore.com> + + * libgnat/s-thread__ae653.adb (taskVarAdd): Defunct, so remove. + (Current_ATSD): Make it a TLS variable. + (OK): Move to package scope. + (System.Storage_Elements): Import and Use. + +2020-07-16 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch9.adb (Expand_N_Accept_Statement): Set Parent of the + created block entity to the created block statement. + +2020-07-16 Arnaud Charlet <charlet@adacore.com> + + * scng.adb (Scan): Detect wide characters not in NFKC. + * libgnat/a-chahan.adb, libgnat/a-chahan.ads, + libgnat/a-wichha.adb, libgnat/a-wichha.ads, + libgnat/a-wichun.adb, libgnat/a-wichun.ads, + libgnat/a-zchhan.adb, libgnat/a-zchhan.ads, + libgnat/a-zchuni.adb, libgnat/a-zchuni.ads (Is_NFKC): New. + * libgnat/s-utf_32.ads, libgnat/s-utf_32.adb (Is_UTF_32_NFKC): + New. + +2020-07-16 Bob Duff <duff@adacore.com> + + * libgnat/s-rident.ads (Restriction_Id): Add + No_Tasks_Unassigned_To_CPU. + +2020-07-16 Bob Duff <duff@adacore.com> + + * exp_aggr.adb (Max_Aggregate_Size): Use the small size of 64 + when copying is needed (for example, for the initialization of a + local variable, and for assignment statements). Use the larger + size when static allocation can be done without copying. + +2020-07-16 Bob Duff <duff@adacore.com> + + * libgnat/s-rident.ads (No_Dynamic_CPU_Assignment): New + restriction. Add it to all relevant profiles. + * sem_ch13.adb (Attribute_CPU): Check No_Dynamic_CPU_Assignment + restriction. + (Attribute_CPU, Attribute_Dispatching_Domain, + Attribute_Interrupt_Priority): Remove error checks -- these are + checked in the parser. + * sem_prag.adb (Pragma_CPU): Check No_Dynamic_CPU_Assignment + restriction. We've got a little violation of DRY here. + * sem.ads, sem_ch3.ads: Minor comment fix. + +2020-07-16 Gary Dismukes <dismukes@adacore.com> + + * sem_ch4.adb (Try_Container_Indexing): When the prefix type is + an access type, change it to the designated type, change the + prefix to an explicit dereference, and emit a ?d? warning for + the implicit dereference. Include a ??? comment questioning + whether this is the right context in which to perform the + implicit dereferencing. + +2020-07-16 Arnaud Charlet <charlet@adacore.com> + + * sem_ch13.adb (Validate_Literal_Aspect): Ensure that the + parameter is not aliased. Minor reformatting. + * sem_util.adb (Statically_Names_Object): Update comment. + +2020-07-16 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_case.adb (Build_Choice): Set Is_Static_Expression flag. + (Lit_Of): Update specification to mention Is_Static_Expression + flag. + * sem_ch13.adb (Membership_Entry): Check for N_Others_Choice. + +2020-07-16 Bob Duff <duff@adacore.com> + + * sem_ch6.adb (Null_Exclusions_Match): New function to check + that the null exclusions match, including in the case addressed + by this AI. + (Check_Conformance): Remove calls to Comes_From_Source + when calling Null_Exclusions_Match. These are not + needed, as indicated by an ancient "???" comment. + +2020-07-16 Justin Squirek <squirek@adacore.com> + + * exp_ch4.adb (Expand_N_Type_Conversion): Remove flawed test for + whether "statically deeper" accessibility rules apply to a given + target type and instead use the new routine + Statically_Deeper_Relation_Applies. + (Statically_Deeper_Relation_Applies): Created to centralize the + calculation of whether a target type within a conversion must + have static accessibility checks. + * sem_ch13.adb (Check_One_Function): Minor comment revision. + +2020-07-16 Eric Botcazou <ebotcazou@adacore.com> + + * fe.h (Is_OK_Static_Expression): Delete. + * sem_eval.ads (Is_OK_Static_Expression): Remove WARNING note. + +2020-07-16 Justin Squirek <squirek@adacore.com> + + * einfo.adb, einfo.ads (Is_Named_Access_Type): Created for + readability. + * sem_ch6.adb (Check_Return_Construct_Accessibility): Add + special cases for formals. + * sem_util.adb (Object_Access_Level): Add handling of access + attributes and named access types in the general case. + +2020-07-16 Piotr Trojanek <trojanek@adacore.com> + + * sem_case.adb (Build_Choice): Simplify. + +2020-07-16 Arnaud Charlet <charlet@adacore.com> + + * frontend.adb: Disable Initialize_Scalars on runtime files. + +2020-07-16 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Add + Comes_From_Source call. + +2020-07-16 Javier Miranda <miranda@adacore.com> + + * exp_attr.adb (Expand_Access_To_Protected_Op): Initialize + variable Sub to Empty to avoid false positive reported by + Codepeer. + +2020-07-16 Arnaud Charlet <charlet@adacore.com> + + * sem_ch8.adb (Note_Redundant_Use): Add missing warning tag. + Do not check for redundant use clauses in predefined units to avoid + misleading warnings that may occur as part of a rtsfind load. + +2020-07-16 Javier Miranda <miranda@adacore.com> + + * exp_attr.adb (Has_By_Protected_Procedure_Prefixed_View): New + subprogram. + (Expand_Access_To_Protected_Op): Adding support for prefixed + class-wide view with By_Protected_Procedure convention. + * sem_attr.adb (Get_Convention): New subprogram. + (Get_Kind): Adapted to use Get_Convention. + * sem_ch4.adb (Try_By_Protected_Procedure_Prefixed_View): New + subprogram. + (Analyze_Selected_Component): Invoke + Try_By_Protected_Procedure_Prefixed_View. + * sem_util.ads (Is_By_Protected_Procedure): New subprogram. + * sem_util.adb (Is_By_Protected_Procedure): New subprogram. + +2020-07-16 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-ststop.ads: Fix typo. + * libgnat/s-ststop.adb (Read, Write): Fix block number + computation to avoid overflows in case of large strings. + +2020-07-16 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-genbig.adb ("**"): Remove capacity limit check. + Improve code by using an extended return. + (Normalize): Perform capacity limit check here instead which is + the centralized place where (potentially large) big integers are + allocated. + +2020-07-16 Gary Dismukes <dismukes@adacore.com> + + * exp_ch4.adb (Expand_N_Type_Conversion): Handle the case of + applying an invariant check for a conversion to a class-wide + type whose root type has a type invariant, when the conversion + appears within the immediate scope of the type and the + expression is of a specific tagged type. + * sem_ch3.adb (Is_Private_Primitive): New function to determine + whether a primitive subprogram is a private operation. + (Check_Abstract_Overriding): Enforce the restriction imposed by + AI12-0042 of requiring overriding of an inherited nonabstract + private operation when the ancestor has a class-wide type + invariant and the ancestor's private operation is visible. + (Derive_Subprogram): Set Requires_Overriding on a subprogram + inherited from a visible private operation of an ancestor to + which a Type_Invariant'Class expression applies. + +2020-07-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Find_Overlaid_Entity): Fix style in comment. + (Note_Possible_Modification): Simplify repeated calls to Ekind. + +2020-07-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Flatten): Adjust description. + (Convert_To_Positional): Remove obsolete ??? comment and use + Compile_Time_Known_Value in the final test. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * par-ch4.adb (P_Iterated_Component_Association): Extended to + recognzize the similar Iterated_Element_Association. This node + is only generated when an explicit Key_Expression is given. + Otherwise the distinction between the two iterated forms is done + during semantic analysis. + * sinfo.ads: New node N_Iterated_Element_Association, for + Ada202x container aggregates. New field Key_Expression. + * sinfo.adb: Subprograms for new node and newn field. + * sem_aggr.adb (Resolve_Iterated_Component_Association): Handle + the case where the Iteration_Scheme is an + Iterator_Specification. + * exp_aggr.adb (Wxpand_Iterated_Component): Handle a component + with an Iterated_Component_Association, generate proper loop + using given Iterator_Specification. + * exp_util.adb (Insert_Axtions): Handle new node as other + aggregate components. + * sem.adb, sprint.adb: Handle new node. + * tbuild.adb (Make_Implicit_Loop_Statement): Handle properly a + loop with an Iterator_ specification. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-stposu.adb (Allocate_Any_Controlled): Fix logic in + lock/unlock. + +2020-07-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_Object_Reference): Return True on + N_Target_Name. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Add proper + handling of Aspect_Predicate_Failure, consistent with + Check_Aspect_At_Freeze_Point. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * sem_ch13.adb (Check_Aspect_Too_Late): Mention -gnat2020 switch + in error message. + +2020-07-15 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Delayed Freezing and Elaboration): Adjust description. + * freeze.adb (Freeze_Object_Declaration): Likewise. + * sem_ch3.adb (Delayed_Aspect_Present): Likewise. Do not return + true for Alignment. + * sem_ch13.adb (Analyze_Aspect_Specifications): Do not always delay + for Alignment. Moreover, for Alignment and various Size aspects, + do not delay if the expression is an attribute whose prefix is the + Standard package. + +2020-07-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Requires_Atomic_Or_Volatile_Copy): Return false + inside an initialization procedure. + +2020-07-15 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_util.adb (Is_Renaming): Add ekind checks. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Remove doc on obsolete + tools. + * gnat_ugn.texi: Regenerate. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * sem_res.adb (Resolve_Type_Conversion): Protect against null + entity. Add proper tag for -gnatwr warning. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * sem_ch6.adb (Analyze_Procedure_Call): Detect use of operators + in a procedure call. + * sem_util.adb: Minor edit. + +2020-07-15 Piotr Trojanek <trojanek@adacore.com> + + * exp_spark.adb (Expand_SPARK_Delta_Or_Update): Apply scalar + range checks against the base type of an index type, not against + the index type itself. + +2020-07-15 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Delayed Freezing and Elaboration): Minor tweaks. + Document the discrepancy between the aspect and the non-aspect + cases for alignment settings in object declarations. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * exp_ch3.adb (Freeze_Type): Remove warning in expander, + replaced by a corresponding error in sem_ch13.adb. Replace + RTE_Available by RTU_Loaded to avoid adding unnecessary + dependencies. + * sem_ch13.adb (Associate_Storage_Pool): New procedure. + (Analyze_Attribute_Definition_Clause + [Attribute_Simple_Storage_Pool| Attribute_Storage_Pool]): Call + Associate_Storage_Pool to add proper legality checks on + subpools. + +2020-07-15 Yannick Moy <moy@adacore.com> + + * libgnat/a-cbdlli.adb, libgnat/a-cbdlli.ads, + libgnat/a-cbhama.adb, libgnat/a-cbhama.ads, + libgnat/a-cbhase.adb, libgnat/a-cbhase.ads, + libgnat/a-cbmutr.adb, libgnat/a-cbmutr.ads, + libgnat/a-cborma.adb, libgnat/a-cborma.ads, + libgnat/a-cborse.adb, libgnat/a-cborse.ads, + libgnat/a-cbprqu.adb, libgnat/a-cbprqu.ads, + libgnat/a-cbsyqu.adb, libgnat/a-cbsyqu.ads, + libgnat/a-cdlili.adb, libgnat/a-cdlili.ads, + libgnat/a-cidlli.adb, libgnat/a-cidlli.ads, + libgnat/a-cihama.adb, libgnat/a-cihama.ads, + libgnat/a-cihase.adb, libgnat/a-cihase.ads, + libgnat/a-cimutr.adb, libgnat/a-cimutr.ads, + libgnat/a-ciorma.adb, libgnat/a-ciorma.ads, + libgnat/a-ciormu.adb, libgnat/a-ciormu.ads, + libgnat/a-ciorse.adb, libgnat/a-ciorse.ads, + libgnat/a-cohama.adb, libgnat/a-cohama.ads, + libgnat/a-cohase.adb, libgnat/a-cohase.ads, + libgnat/a-coinve.adb, libgnat/a-coinve.ads, + libgnat/a-comutr.adb, libgnat/a-comutr.ads, + libgnat/a-convec.adb, libgnat/a-convec.ads, + libgnat/a-coorma.adb, libgnat/a-coorma.ads, + libgnat/a-coormu.adb, libgnat/a-coormu.ads, + libgnat/a-coorse.adb, libgnat/a-coorse.ads: Add SPARK_Mode => + Off. + +2020-07-15 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch3.adb (Delayed_Aspect_Present): Fix oversight in loop. + * freeze.adb (Freeze_Object_Declaration): Use Declaration_Node + instead of Parent for the sake of consistency. + +2020-07-15 Javier Miranda <miranda@adacore.com> + + * sem_attr.adb (Resolve_Attribute): Resolve overloaded + N_Selected_Component prefix of 'Access. Required to handle + overloaded prefixed view of protected subprograms. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/about_this_guide.rst: Remove old section and + update for Ada 202x. + * doc/gnat_ugn/getting_started_with_gnat.rst: Add a system + requirements section. Remove obsolete section and minimal + rewording on the getting started section. + * gnat_ugn.texi: Regenerate. + +2020-07-15 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch5.adb (Expand_Assign_Array): Use short-circuit operator + (style). + * sem_res.adb (Resolve_Indexed_Component): Fix style in comment. + * sem_util.adb (Is_Effectively_Volatile_Object): Handle slices + just like indexed components; handle qualified expressions and + type conversions lie in Is_OK_Volatile_Context. + (Is_OK_Volatile_Context): Handle qualified expressions just like + type conversions. + +2020-07-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Atomic_Components): Simplify with Ekind_In. + (Complex_Representation): Fix type of E_Id, which just like when + for pragma Atomic_Components will hold an N_Identifier node, not + an entity. + * sem_util.adb (Is_Effectively_Volatile): Refactor to avoid + unnecessary computation. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * inline.adb, inline.ads + (Inline_Static_Expression_Function_Call): Renamed + Inline_Static_Function_Call. + * sem_ch13.adb (Analyze_Aspect_Static): Allow static intrinsic + imported functions under -gnatX. + * sem_util.ads, sem_util.adb (Is_Static_Expression_Function): + Renamed Is_Static_Function. + (Is_Static_Expression_Function_Call): Renamed + Is_Static_Function_Call. + * sem_ch6.adb, sem_elab.adb, sem_res.adb: Update calls to + Is_Static_Function*. + * sem_eval.adb (Fold_Dummy, Eval_Intrinsic_Call, Fold_Shift): + New. + (Eval_Call): Add support for intrinsic calls, code refactoring. + (Eval_Entity_Name): Code refactoring. + (Eval_Logical_Op): Update comment. + (Eval_Shift): Call Fold_Shift. Update comments. + * par-prag.adb (Par [Pragma_Extensions_Allowed]): Set + Ada_Version to Ada_Version_Type'Last to handle + Extensions_Allowed (On) consistently. + * opt.ads (Extensions_Allowed): Update documentation. + * sem_attr.adb: Update comment. + * doc/gnat_rm/implementation_defined_pragmas.rst: Update + documentation of Extensions_Allowed. + * gnat_rm.texi: Regenerate. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): Ensure + Typ is never accessed uninitialized. + +2020-07-15 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_rm/representation_clauses_and_pragmas.rst: Fix typo. + * gnat_rm.texi: Regenerate. + * libgnat/s-secsta.ads (Memory_Alignment): Likewise. + +2020-07-15 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb: Add a comma and fix a typo (machinary => + machinery) in comment. + * exp_aggr.adb: Reformat, fix capitalization, and add a couple + of commas in a comment. Adjust columns in several code + fragments. + * sem_aggr.adb: Reformat and add a comma in a comment. + +2020-07-15 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch9.adb (Expand_N_Timed_Entry_Call): Use the Sloc of + the delay statement in the expansion. + +2020-07-15 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): New + procedure, internal to Resolve_Container_Aggregate, to complete + semantic analysis of Iterated_Component_Associations. + * exp_aggr.adb (Expand_Iterated_Component): New procedure, + internal to Expand_Container_Aggregate, to expand the construct + into an implicit loop that performs individual insertions into + the target aggregate. + +2020-07-15 Justin Squirek <squirek@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Call_Allocator): Normalize + the associated node for internally generated objects to be like + their SOAAT counter-parts. + +2020-07-15 Arnaud Charlet <charlet@adacore.com> + + * libgnat/g-socket.adb (Wait_On_Socket): Fix potentially + uninitialized variable. + 2020-07-10 Piotr Trojanek <trojanek@adacore.com> * sem_ch8.adb (Find_Direct_Name): Fix code to match the comment. @@ -1035,39 +1891,39 @@ * par-ch6.adb (P_Return_Object_Declaration): Set Has_Init_Expression flag. -2020-07-02 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-07-02 Eric Botcazou <ebotcazou@adacore.com> * debug.adb (d.K): Document new usage. * fe.h (Debug_Flag_Dot_KK): Declare. * gcc-interface/decl.c (gnat_to_gnu_field): Give an error when the component overlaps with the parent subtype, except with -gnatd.K. -2020-06-26 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-26 Eric Botcazou <ebotcazou@adacore.com> * exp_ch4.adb (Expand_Set_Membership): Expand the membership test using left associativity instead of right associativity. -2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-23 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/utils2.c (build_binary_op): Remove space. -2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-23 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/trans.c (gnat_to_gnu) <N_Allocator>: Minor tweaks. Call Has_Constrained_Partial_View on base type of designated type. -2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-23 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/utils.c (gnat_write_global_declarations): Output integral global variables first and the imported functions later. -2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-23 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (elaborate_expression_1): When GNAT encodings are not used, do not create a variable for debug info purposes if the expression is itself a user-declared variable. -2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-23 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/ada-tree.h (DECL_RENAMED_OBJECT): Delete. * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Always use @@ -1079,17 +1935,17 @@ Do not deal with side-effects here. <N_Exception_Renaming_Declaration>: Likewise. -2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-23 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (elaborate_expression): Replace calls to Is_OK_Static_Expression with Compile_Time_Known_Value. -2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-23 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Set debug type to the base type and only if the subtype is artificial. -2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-06-23 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/trans.c (gnat_to_gnu) <N_Assignment_Statement>: Do not test Is_Bit_Packed_Array in the memset path. @@ -7045,7 +7901,7 @@ * gnatvsn.ads: Bump Library_Version to 11. -2020-05-26 Eric Botcazou <ebotcazou@gcc.gnu.org> +2020-05-26 Eric Botcazou <ebotcazou@adacore.com> PR ada/95333 * gcc-interface/decl.c (gnat_to_gnu_param): Never make a variant of diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 73109a2..fc978a2 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -834,13 +834,13 @@ ATOMICS_BUILTINS_TARGET_PAIRS = \ # Special version of units for x86 and x86-64 platforms. X86_TARGET_PAIRS = \ - a-numaux.ads<libgnat/a-numaux__x86.ads \ - a-numaux.adb<libgnat/a-numaux__x86.adb \ + a-numaux.ads<libgnat/a-numaux__libc-x86.ads \ + a-numaux.adb<libgnat/a-numaux__dummy.adb \ s-atocou.adb<libgnat/s-atocou__x86.adb X86_64_TARGET_PAIRS = \ - a-numaux.ads<libgnat/a-numaux__x86.ads \ - a-numaux.adb<libgnat/a-numaux__x86.adb \ + a-numaux.ads<libgnat/a-numaux__libc-x86.ads \ + a-numaux.adb<libgnat/a-numaux__dummy.adb \ s-atocou.adb<libgnat/s-atocou__builtin.adb # Implementation of symbolic traceback based on dwarf @@ -1648,8 +1648,8 @@ endif ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ - a-numaux.adb<libgnat/a-numaux__x86.adb \ - a-numaux.ads<libgnat/a-numaux__x86.ads \ + a-numaux.ads<libgnat/a-numaux__libc-x86.ads \ + a-numaux.adb<libgnat/a-numaux__dummy.adb \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__posix.adb \ s-osinte.adb<libgnarl/s-osinte__posix.adb \ @@ -1911,7 +1911,6 @@ ifeq ($(strip $(filter-out lynxos178%,$(target_os))),) endif ifeq ($(strip $(filter-out %86, $(target_cpu))),) LIBGNAT_TARGET_PAIRS += system.ads<libgnat/system-lynxos178-x86.ads - LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS) endif ifeq ($(strip $(filter-out lynxos178e,$(target_os))),) diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index c55f4ed..c222c33 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -142,12 +142,9 @@ package body Aspects is -- The routine should be invoked on a body [stub] with aspects pragma Assert (Has_Aspects (N)); - pragma Assert (Nkind (N) in N_Body_Stub - or else Nkind_In (N, N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body)); + pragma Assert + (Nkind (N) in N_Body_Stub | N_Entry_Body | N_Package_Body | + N_Protected_Body | N_Subprogram_Body | N_Task_Body); -- Look through all aspects and see whether they can be applied to a -- body [stub]. @@ -401,9 +398,8 @@ package body Aspects is -- Note: It is better to use Is_Single_Concurrent_Type_Declaration -- here, but Aspects and Sem_Util have incompatible licenses. - elsif Nkind_In - (Original_Node (From), N_Single_Protected_Declaration, - N_Single_Task_Declaration) + elsif Nkind (Original_Node (From)) in + N_Single_Protected_Declaration | N_Single_Task_Declaration then Asp_Id := Get_Aspect_Id (Asp); diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 4e517d1..0394106 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -189,6 +189,7 @@ package Aspects is Aspect_Atomic_Components, Aspect_Disable_Controlled, -- GNAT Aspect_Discard_Names, + Aspect_CUDA_Global, -- GNAT Aspect_Export, Aspect_Favor_Top_Level, -- GNAT Aspect_Independent, @@ -458,6 +459,7 @@ package Aspects is Aspect_Contract_Cases => False, Aspect_Convention => True, Aspect_CPU => False, + Aspect_CUDA_Global => False, Aspect_Default_Component_Value => True, Aspect_Default_Initial_Condition => False, Aspect_Default_Iterator => False, @@ -601,6 +603,7 @@ package Aspects is Aspect_Contract_Cases => Name_Contract_Cases, Aspect_Convention => Name_Convention, Aspect_CPU => Name_CPU, + Aspect_CUDA_Global => Name_CUDA_Global, Aspect_Default_Component_Value => Name_Default_Component_Value, Aspect_Default_Initial_Condition => Name_Default_Initial_Condition, Aspect_Default_Iterator => Name_Default_Iterator, @@ -839,6 +842,7 @@ package Aspects is Aspect_Attach_Handler => Always_Delay, Aspect_Constant_Indexing => Always_Delay, Aspect_CPU => Always_Delay, + Aspect_CUDA_Global => Always_Delay, Aspect_Default_Iterator => Always_Delay, Aspect_Default_Storage_Pool => Always_Delay, Aspect_Default_Value => Always_Delay, diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 1a00f59..7e05a48 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -994,336 +994,6 @@ package body Atree is return N_To_E (Nodes.Table (E + 1).Nkind); end Ekind; - -------------- - -- Ekind_In -- - -------------- - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind; - V10 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9 or else - T = V10; - end Ekind_In; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind; - V10 : Entity_Kind; - V11 : Entity_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9 or else - T = V10 or else - T = V11; - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2, V3); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2, V3, V4); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2, V3, V4, V5); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind; - V10 : Entity_Kind) return Boolean - is - begin - return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10); - end Ekind_In; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind; - V10 : Entity_Kind; - V11 : Entity_Kind) return Boolean - is - begin - return - Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, V11); - end Ekind_In; - ------------------ -- Error_Posted -- ------------------ @@ -1783,171 +1453,6 @@ package body Atree is return Nodes.Table (N).Nkind; end Nkind; - -------------- - -- Nkind_In -- - -------------- - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4, V5); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind; - V11 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, - V11); - end Nkind_In; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind; - V11 : Node_Kind; - V12 : Node_Kind; - V13 : Node_Kind; - V14 : Node_Kind; - V15 : Node_Kind; - V16 : Node_Kind; - V17 : Node_Kind) return Boolean - is - begin - return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, - V11, V12, V13, V14, V15, V16, V17); - end Nkind_In; - -------- -- No -- -------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 68415d4..e958a9b 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -670,335 +670,6 @@ package Atree is function Sloc (N : Node_Id) return Source_Ptr; pragma Inline (Sloc); - --------------------- - -- Node_Kind Tests -- - --------------------- - - -- These are like the functions in Sinfo, but the first argument is a - -- Node_Id, and the tested field is Nkind (N). - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind) return Boolean; - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind; - V11 : Node_Kind) return Boolean; - - -- 12..16-parameter versions are not yet needed - - function Nkind_In - (N : Node_Id; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind; - V11 : Node_Kind; - V12 : Node_Kind; - V13 : Node_Kind; - V14 : Node_Kind; - V15 : Node_Kind; - V16 : Node_Kind; - V17 : Node_Kind) return Boolean; - - pragma Inline (Nkind_In); - -- Inline all above functions - - ----------------------- - -- Entity_Kind_Tests -- - ----------------------- - - -- Utility functions to test whether an Entity_Kind value, either given - -- directly as the first argument, or the Ekind field of an Entity given - -- as the first argument, matches any of the given list of Entity_Kind - -- values. Return True if any match, False if no match. - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind; - V10 : Entity_Kind) return Boolean; - - function Ekind_In - (E : Entity_Id; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind; - V10 : Entity_Kind; - V11 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind; - V10 : Entity_Kind) return Boolean; - - function Ekind_In - (T : Entity_Kind; - V1 : Entity_Kind; - V2 : Entity_Kind; - V3 : Entity_Kind; - V4 : Entity_Kind; - V5 : Entity_Kind; - V6 : Entity_Kind; - V7 : Entity_Kind; - V8 : Entity_Kind; - V9 : Entity_Kind; - V10 : Entity_Kind; - V11 : Entity_Kind) return Boolean; - - pragma Inline (Ekind_In); - -- Inline all above functions - ----------------------------- -- Entity Access Functions -- ----------------------------- diff --git a/gcc/ada/bindo-diagnostics.adb b/gcc/ada/bindo-diagnostics.adb index c2ffe44..ed1abf8 100644 --- a/gcc/ada/bindo-diagnostics.adb +++ b/gcc/ada/bindo-diagnostics.adb @@ -25,7 +25,6 @@ with Binderr; use Binderr; with Debug; use Debug; -with Restrict; use Restrict; with Rident; use Rident; with Types; use Types; @@ -1144,7 +1143,7 @@ package body Bindo.Diagnostics is -- within the task body on a select or accept statement, eliminating -- subsequent invocation edges, thus breaking the cycle. - if not Restriction_Active (No_Entry_Calls_In_Elaboration_Code) + if not Cumulative_Restrictions.Set (No_Entry_Calls_In_Elaboration_Code) and then Contains_Task_Activation (G, Cycle) then Error_Msg_Info diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 46a878e..9de21d6 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -433,7 +433,7 @@ package body Checks is -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check -- for zero-divide is a divide check, not an overflow check). - if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then + if Nkind (N) in N_Op_Rem | N_Op_Mod | N_Op_Plus then return; end if; end if; @@ -585,7 +585,7 @@ package body Checks is if Ada_Version >= Ada_2012 and then not Present (Param_Ent) and then Is_Entity_Name (N) - and then Ekind_In (Entity (N), E_Constant, E_Variable) + and then Ekind (Entity (N)) in E_Constant | E_Variable and then Present (Effective_Extra_Accessibility (Entity (N))) then Param_Ent := Entity (N); @@ -621,9 +621,8 @@ package body Checks is -- deepest type level so as to appropriatly handle the rules for -- RM 3.10.2 (10.1/3). - if Ekind_In (Scope (Param_Ent), E_Function, - E_Operator, - E_Subprogram_Type) + if Ekind (Scope (Param_Ent)) + in E_Function | E_Operator | E_Subprogram_Type and then Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then Type_Level := @@ -1204,7 +1203,7 @@ package body Checks is -- there is no overflow check that starts from that parent node, -- so apply check now. - if Nkind_In (P, N_If_Expression, N_Case_Expression) + if Nkind (P) in N_If_Expression | N_Case_Expression and then not Is_Signed_Integer_Arithmetic_Op (Parent (P)) then null; @@ -2713,11 +2712,11 @@ package body Checks is -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars] -- mode OUT - Post => Formal'Valid[_Scalars] - if Ekind_In (Formal, E_In_Parameter, E_In_Out_Parameter) then + if Ekind (Formal) in E_In_Parameter | E_In_Out_Parameter then Add_Validity_Check (Formal, Name_Precondition, False); end if; - if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then + if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then Add_Validity_Check (Formal, Name_Postcondition, False); end if; @@ -2850,7 +2849,7 @@ package body Checks is (Typ, New_Occurrence_Of (Entity (N), Sloc (N)))); return; - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then -- If the expression is an aggregate in an assignment, apply the -- check to the LHS after the assignment, rather than create a @@ -4037,9 +4036,9 @@ package body Checks is function Left_Expression (Op : Node_Id) return Node_Id is LE : Node_Id := Left_Opnd (Op); begin - while Nkind_In (LE, N_Qualified_Expression, - N_Type_Conversion, - N_Expression_With_Actions) + while Nkind (LE) in N_Qualified_Expression + | N_Type_Conversion + | N_Expression_With_Actions loop LE := Expression (LE); end loop; @@ -4249,11 +4248,11 @@ package body Checks is begin pragma Assert - (Nkind_In (Kind, N_Component_Declaration, - N_Discriminant_Specification, - N_Function_Specification, - N_Object_Declaration, - N_Parameter_Specification)); + (Kind in N_Component_Declaration + | N_Discriminant_Specification + | N_Function_Specification + | N_Object_Declaration + | N_Parameter_Specification); if Kind = N_Function_Specification then Typ := Etype (Defining_Entity (N)); @@ -6078,7 +6077,7 @@ package body Checks is -- Likewise for Abs/Minus, the only case where the operation can -- overflow is when the operand is the largest negative number. - elsif Nkind_In (N, N_Op_Abs, N_Op_Minus) then + elsif Nkind (N) in N_Op_Abs | N_Op_Minus then Determine_Range (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); @@ -6220,7 +6219,7 @@ package body Checks is -- Do not set range check flag if parent is assignment statement or -- object declaration with Suppress_Assignment_Checks flag set - if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration) + if Nkind (Parent (N)) in N_Assignment_Statement | N_Object_Declaration and then Suppress_Assignment_Checks (Parent (N)) then return; @@ -6581,9 +6580,9 @@ package body Checks is -- If this is an indirect or dispatching call, get signature -- from the subprogram type. - if Nkind_In (P, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (P) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then E := Get_Called_Entity (P); L := Parameter_Associations (P); @@ -6714,13 +6713,13 @@ package body Checks is -- Integer and character literals always have valid values, where -- appropriate these will be range checked in any case. - elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then + elsif Nkind (Expr) in N_Integer_Literal | N_Character_Literal then return True; -- If we have a type conversion or a qualification of a known valid -- value, then the result will always be valid. - elsif Nkind_In (Expr, N_Type_Conversion, N_Qualified_Expression) then + elsif Nkind (Expr) in N_Type_Conversion | N_Qualified_Expression then return Expr_Known_Valid (Expression (Expr)); -- Case of expression is a non-floating-point operator. In this case we @@ -7059,9 +7058,7 @@ package body Checks is begin P := Prefix (N); while not Is_Entity_Name (P) loop - if not Nkind_In (P, N_Selected_Component, - N_Indexed_Component) - then + if Nkind (P) not in N_Selected_Component | N_Indexed_Component then return Empty; end if; @@ -7174,7 +7171,7 @@ package body Checks is if Nkind (A_Idx) = N_Range then A_Range := A_Idx; - elsif Nkind_In (A_Idx, N_Identifier, N_Expanded_Name) then + elsif Nkind (A_Idx) in N_Identifier | N_Expanded_Name then A_Range := Scalar_Range (Entity (A_Idx)); if Nkind (A_Range) = N_Subtype_Indication then @@ -7362,7 +7359,8 @@ package body Checks is -- the target. and then not - (Nkind_In (N, N_Integer_Literal, N_Real_Literal, N_Character_Literal) + (Nkind (N) in + N_Integer_Literal | N_Real_Literal | N_Character_Literal or else (Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Enumeration_Literal)) @@ -8533,9 +8531,8 @@ package body Checks is -- need to be called while elaboration is taking place. elsif Is_Controlled (Tag_Typ) - and then Nam_In (Chars (Subp_Id), Name_Adjust, - Name_Finalize, - Name_Initialize) + and then + Chars (Subp_Id) in Name_Adjust | Name_Finalize | Name_Initialize then return; end if; diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 50d8422..9d3e9e9 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -154,7 +154,7 @@ package body Contracts is -- Refined_Post elsif Is_Entry_Body (Id) then - if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then + if Prag_Nam in Name_Refined_Depends | Name_Refined_Global then Add_Classification; elsif Prag_Nam = Name_Refined_Post then @@ -179,31 +179,31 @@ package body Contracts is -- Volatile_Function elsif Is_Entry_Declaration (Id) - or else Ekind_In (Id, E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Procedure) + or else Ekind (Id) in E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Procedure then - if Nam_In (Prag_Nam, Name_Attach_Handler, Name_Interrupt_Handler) - and then Ekind_In (Id, E_Generic_Procedure, E_Procedure) + if Prag_Nam in Name_Attach_Handler | Name_Interrupt_Handler + and then Ekind (Id) in E_Generic_Procedure | E_Procedure then Add_Classification; - elsif Nam_In (Prag_Nam, Name_Depends, - Name_Extensions_Visible, - Name_Global) + elsif Prag_Nam in Name_Depends + | Name_Extensions_Visible + | Name_Global then Add_Classification; elsif Prag_Nam = Name_Volatile_Function - and then Ekind_In (Id, E_Function, E_Generic_Function) + and then Ekind (Id) in E_Function | E_Generic_Function then Add_Classification; - elsif Nam_In (Prag_Nam, Name_Contract_Cases, Name_Test_Case) then + elsif Prag_Nam in Name_Contract_Cases | Name_Test_Case then Add_Contract_Test_Case; - elsif Nam_In (Prag_Nam, Name_Postcondition, Name_Precondition) then + elsif Prag_Nam in Name_Postcondition | Name_Precondition then Add_Pre_Post_Condition; -- The pragma is not a proper contract item @@ -219,9 +219,9 @@ package body Contracts is -- Part_Of (instantiation only) elsif Is_Package_Or_Generic_Package (Id) then - if Nam_In (Prag_Nam, Name_Abstract_State, - Name_Initial_Condition, - Name_Initializes) + if Prag_Nam in Name_Abstract_State + | Name_Initial_Condition + | Name_Initializes then Add_Classification; @@ -256,14 +256,14 @@ package body Contracts is elsif Is_Type (Id) then declare Is_OK : constant Boolean := - Nam_In (Prag_Nam, Name_Async_Readers, - Name_Async_Writers, - Name_Effective_Reads, - Name_Effective_Writes) + Prag_Nam in Name_Async_Readers + | Name_Async_Writers + | Name_Effective_Reads + | Name_Effective_Writes or else (Ekind (Id) = E_Task_Type - and Nam_In (Prag_Nam, Name_Part_Of, - Name_Depends, - Name_Global)) + and Prag_Nam in Name_Part_Of + | Name_Depends + | Name_Global) or else (Ekind (Id) = E_Protected_Type and Prag_Nam = Name_Part_Of); begin @@ -285,12 +285,12 @@ package body Contracts is -- Refined_Post elsif Ekind (Id) = E_Subprogram_Body then - if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then + if Prag_Nam in Name_Refined_Depends | Name_Refined_Global then Add_Classification; - elsif Nam_In (Prag_Nam, Name_Postcondition, - Name_Precondition, - Name_Refined_Post) + elsif Prag_Nam in Name_Postcondition + | Name_Precondition + | Name_Refined_Post then Add_Pre_Post_Condition; @@ -305,7 +305,7 @@ package body Contracts is -- Refined_Global elsif Ekind (Id) = E_Task_Body then - if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then + if Prag_Nam in Name_Refined_Depends | Name_Refined_Global then Add_Classification; -- The pragma is not a proper contract item @@ -331,15 +331,15 @@ package body Contracts is -- Part_Of elsif Ekind (Id) = E_Variable then - if Nam_In (Prag_Nam, Name_Async_Readers, - Name_Async_Writers, - Name_Constant_After_Elaboration, - Name_Depends, - Name_Effective_Reads, - Name_Effective_Writes, - Name_Global, - Name_No_Caching, - Name_Part_Of) + if Prag_Nam in Name_Async_Readers + | Name_Async_Writers + | Name_Constant_After_Elaboration + | Name_Depends + | Name_Effective_Reads + | Name_Effective_Writes + | Name_Global + | Name_No_Caching + | Name_Part_Of then Add_Classification; @@ -367,10 +367,10 @@ package body Contracts is -- Entry or subprogram declarations - if Nkind_In (Decl, N_Abstract_Subprogram_Declaration, - N_Entry_Declaration, - N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) + if Nkind (Decl) in N_Abstract_Subprogram_Declaration + | N_Entry_Declaration + | N_Generic_Subprogram_Declaration + | N_Subprogram_Declaration then declare Subp_Id : constant Entity_Id := Defining_Entity (Decl); @@ -392,7 +392,7 @@ package body Contracts is -- Entry or subprogram bodies - elsif Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then + elsif Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then Analyze_Entry_Or_Subprogram_Body_Contract (Defining_Entity (Decl)); -- Objects @@ -407,8 +407,8 @@ package body Contracts is -- Protected units - elsif Nkind_In (Decl, N_Protected_Type_Declaration, - N_Single_Protected_Declaration) + elsif Nkind (Decl) in N_Protected_Type_Declaration + | N_Single_Protected_Declaration then Analyze_Protected_Contract (Defining_Entity (Decl)); @@ -419,8 +419,8 @@ package body Contracts is -- Task units - elsif Nkind_In (Decl, N_Single_Task_Declaration, - N_Task_Type_Declaration) + elsif Nkind (Decl) in N_Single_Task_Declaration + | N_Task_Type_Declaration then Analyze_Task_Contract (Defining_Entity (Decl)); @@ -459,11 +459,11 @@ package body Contracts is end; end if; - if Nkind_In (Decl, N_Full_Type_Declaration, - N_Private_Type_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration, - N_Formal_Type_Declaration) + if Nkind (Decl) in N_Full_Type_Declaration + | N_Private_Type_Declaration + | N_Task_Type_Declaration + | N_Protected_Type_Declaration + | N_Formal_Type_Declaration then Analyze_Type_Contract (Defining_Identifier (Decl)); end if; @@ -528,7 +528,7 @@ package body Contracts is -- subprograms. if SPARK_Mode = On - and then Ekind_In (Body_Id, E_Function, E_Generic_Function) + and then Ekind (Body_Id) in E_Function | E_Generic_Function and then Comes_From_Source (Spec_Id) and then not Is_Volatile_Function (Body_Id) then @@ -737,7 +737,7 @@ package body Contracts is -- processed after the analysis of the related subprogram declaration. if SPARK_Mode = On - and then Ekind_In (Subp_Id, E_Function, E_Generic_Function) + and then Ekind (Subp_Id) in E_Function | E_Generic_Function and then Comes_From_Source (Subp_Id) and then not Is_Volatile_Function (Subp_Id) then @@ -2882,12 +2882,9 @@ package body Contracts is function Causes_Contract_Freezing (N : Node_Id) return Boolean is begin - return Nkind_In (N, N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Subprogram_Body_Stub, - N_Task_Body); + return Nkind (N) in + N_Entry_Body | N_Package_Body | N_Protected_Body | + N_Subprogram_Body | N_Subprogram_Body_Stub | N_Task_Body; end Causes_Contract_Freezing; ---------------------- @@ -2922,10 +2919,10 @@ package body Contracts is -- Entry or subprogram declarations - elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration, - N_Entry_Declaration, - N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) + elsif Nkind (Decl) in N_Abstract_Subprogram_Declaration + | N_Entry_Declaration + | N_Generic_Subprogram_Declaration + | N_Subprogram_Declaration then Analyze_Entry_Or_Subprogram_Contract (Subp_Id => Defining_Entity (Decl), @@ -2940,8 +2937,8 @@ package body Contracts is -- Protected units - elsif Nkind_In (Decl, N_Protected_Type_Declaration, - N_Single_Protected_Declaration) + elsif Nkind (Decl) in N_Protected_Type_Declaration + | N_Single_Protected_Declaration then Analyze_Protected_Contract (Defining_Entity (Decl)); @@ -2952,17 +2949,17 @@ package body Contracts is -- Task units - elsif Nkind_In (Decl, N_Single_Task_Declaration, - N_Task_Type_Declaration) + elsif Nkind (Decl) in N_Single_Task_Declaration + | N_Task_Type_Declaration then Analyze_Task_Contract (Defining_Entity (Decl)); end if; - if Nkind_In (Decl, N_Full_Type_Declaration, - N_Private_Type_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration, - N_Formal_Type_Declaration) + if Nkind (Decl) in N_Full_Type_Declaration + | N_Private_Type_Declaration + | N_Task_Type_Declaration + | N_Protected_Type_Declaration + | N_Formal_Type_Declaration then Analyze_Type_Contract (Defining_Identifier (Decl)); end if; diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 2f60db5..737bc60 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2193,16 +2193,32 @@ extension mode (the use of Off as a parameter cancels the effect of the *-gnatX* command switch). In extension mode, the latest version of the Ada language is -implemented (currently Ada 2012), and in addition a small number +implemented (currently Ada 202x), and in addition a small number of GNAT specific extensions are recognized as follows: +* Constrained attribute for generic objects - -*Constrained attribute for generic objects* The ``Constrained`` attribute is permitted for objects of generic types. The result indicates if the corresponding actual is constrained. +* ``Static`` aspect on intrinsic functions + + The Ada 202x ``Static`` aspect can be specified on Intrinsic imported + 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. + +* ``[]`` aggregates + + This new aggregate syntax for arrays and containers is provided under -gnatX + to experiment and confirm this new language syntax. + + .. _Pragma-Extensions_Visible: Pragma Extensions_Visible diff --git a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst index efcdc80..7bae014 100644 --- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst @@ -582,7 +582,7 @@ that in each case the base is ``Short_Short_Integer`` with a size of 8): Note: the entries marked '*' are not actually specified by the Ada Reference Manual, which has nothing to say about size in the dynamic -case. What GNAT does is to allocate sufficient bits to accomodate any +case. What GNAT does is to allocate sufficient bits to accommodate any possible dynamic values for the bounds at run-time. So far, so good, but GNAT has to obey the RM rules, so the question is diff --git a/gcc/ada/doc/gnat_ugn/about_this_guide.rst b/gcc/ada/doc/gnat_ugn/about_this_guide.rst index 1ab2f4c..3347626 100644 --- a/gcc/ada/doc/gnat_ugn/about_this_guide.rst +++ b/gcc/ada/doc/gnat_ugn/about_this_guide.rst @@ -14,13 +14,13 @@ toolset for the full Ada programming language. It documents the features of the compiler and tools, and explains how to use them to build Ada applications. -GNAT implements Ada 95, Ada 2005 and Ada 2012, and it may also be +GNAT implements Ada 95, Ada 2005, Ada 2012, and Ada 202x, and it may also be invoked in Ada 83 compatibility mode. By default, GNAT assumes Ada 2012, but you can override with a compiler switch (:ref:`Compiling_Different_Versions_of_Ada`) to explicitly specify the language version. Throughout this manual, references to 'Ada' without a year suffix -apply to all Ada 95/2005/2012 versions of the language. +apply to all Ada versions of the language, starting with Ada 95. What This Guide Contains ======================== @@ -71,8 +71,6 @@ What You Should Know before Reading This Guide This guide assumes a basic familiarity with the Ada 95 language, as described in the International Standard ANSI/ISO/IEC-8652:1995, January 1995. -It does not require knowledge of the features introduced by Ada 2005 -or Ada 2012. Reference manuals for Ada 95, Ada 2005, and Ada 2012 are included in the GNAT documentation package. @@ -104,81 +102,6 @@ following documents: environment Emacs. -A Note to Readers of Previous Versions of the Manual -==================================================== - -In early 2015 the GNAT manuals were transitioned to the -reStructuredText (rst) / Sphinx documentation generator technology. -During that process the :title:`GNAT User's Guide` was reorganized -so that related topics would be described together in the same chapter -or appendix. Here's a summary of the major changes realized in -the new document structure. - -* :ref:`The_GNAT_Compilation_Model` has been extended so that it now covers - the following material: - - - The ``gnatname``, ``gnatkr``, and ``gnatchop`` tools - - :ref:`Configuration_Pragmas` - - :ref:`GNAT_and_Libraries` - - :ref:`Conditional_Compilation` including :ref:`Preprocessing_with_gnatprep` - and :ref:`Integrated_Preprocessing` - - :ref:`Generating_Ada_Bindings_for_C_and_C++_headers` - - :ref:`Using_GNAT_Files_with_External_Tools` - -* :ref:`Building_Executable_Programs_With_GNAT` is a new chapter consolidating - the following content: - - - :ref:`The_GNAT_Make_Program_gnatmake` - - :ref:`Compiling_with_GCC` - - :ref:`Binding_with_gnatbind` - - :ref:`Linking_with_gnatlink` - - :ref:`Using_the_GNU_make_Utility` - -* :ref:`GNAT_Utility_Programs` is a new chapter consolidating the information about several - GNAT tools: - - .. only:: PRO or GPL - - - :ref:`The_File_Cleanup_Utility_gnatclean` - - :ref:`The_GNAT_Library_Browser_gnatls` - - :ref:`The_Cross-Referencing_Tools_gnatxref_and_gnatfind` - - :ref:`The_Ada_to_HTML_Converter_gnathtml` - - :ref:`The_Ada-to-XML_Converter_gnat2xml` - - :ref:`The_Coding_Standard_Verifier_gnatcheck` - - :ref:`The_GNAT_Metrics_Tool_gnatmetric` - - :ref:`The_GNAT_Pretty_Printer_gnatpp` - - :ref:`The_Body_Stub_Generator_gnatstub` - - :ref:`The_Unit_Test_Generator_gnattest` - - .. only:: FSF - - - :ref:`The_File_Cleanup_Utility_gnatclean` - - :ref:`The_GNAT_Library_Browser_gnatls` - - :ref:`The_Cross-Referencing_Tools_gnatxref_and_gnatfind` - - :ref:`The_Ada_to_HTML_Converter_gnathtml` - -* :ref:`GNAT_and_Program_Execution` is a new chapter consolidating the following: - - - :ref:`Running_and_Debugging_Ada_Programs` - - :ref:`Profiling` - - :ref:`Improving_Performance` - - :ref:`Overflow Check Handling in GNAT <Overflow_Check_Handling_in_GNAT>` - - :ref:`Performing Dimensionality Analysis in GNAT <Performing_Dimensionality_Analysis_in_GNAT>` - - :ref:`Stack_Related_Facilities` - - :ref:`Memory_Management_Issues` - -* :ref:`Platform_Specific_Information` is a new appendix consolidating the following: - - - :ref:`Run_Time_Libraries` - - :ref:`Microsoft_Windows_Topics` - - :ref:`Mac_OS_Topics` - -* The *Compatibility and Porting Guide* appendix has been moved to the - :title:`GNAT Reference Manual`. It now includes a section - *Writing Portable Fixed-Point Declarations* which was previously - a separate chapter in the :title:`GNAT User's Guide`. - - Conventions =========== .. index:: Conventions, typographical diff --git a/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst b/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst index 34dc355..9814cb6 100644 --- a/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst @@ -9,14 +9,43 @@ Getting Started with GNAT This chapter describes how to use GNAT's command line interface to build executable Ada programs. On most platforms a visually oriented Integrated Development Environment -is also available, the GNAT Programming Studio (GNAT Studio). +is also available: GNAT Studio. GNAT Studio offers a graphical "look and feel", support for development in other programming languages, comprehensive browsing features, and many other capabilities. -For information on GNAT Studio please refer to -:title:`Using the GNAT Programming Studio`. +For information on GNAT Studio please refer to the +:title:`GNAT Studio documentation`. +.. _System_Requirements: + +System Requirements +=================== + +Even though any machine can run the GNAT toolset and GNAT Studio IDE, in order +to get the best experience, we recommend using a machine with as many cores +as possible since all individual compilations can run in parallel. +A comfortable setup for a compiler server is a machine with 24 physical cores +or more, with at least 48 GB of memory (2 GB per core). + +For a desktop machine, a minimum of 4 cores is recommended (8 preferred), +with at least 2GB per core (so 8 to 16GB). + +In addition, for running and navigating sources in GNAT Studio smoothly, we +recommend at least 1.5 GB plus 3 GB of RAM per 1 million source line of code. +In other words, we recommend at least 3 GB for for 500K lines of code and +7.5 GB for 2 million lines of code. + +Note that using local and fast drives will also make a difference in terms of +build and link time. Network drives such as NFS, SMB, or worse, configuration +management filesystems (such as ClearCase dynamic views) should be avoided as +much as possible and will produce very degraded performance (typically 2 to 3 +times slower than on local fast drives). If such slow drives cannot be avoided +for accessing the source code, then you should at least configure your project +file so that the result of the compilation is stored on a drive local to the +machine performing the run. This can be achieved by setting the ``Object_Dir`` +project file attribute. + .. _Running_GNAT: Running GNAT @@ -96,24 +125,12 @@ file corresponding to your Ada program. It also generates an 'Ada Library Information' file :file:`hello.ali`, which contains additional information used to check that an Ada program is consistent. -To build an executable file, -use ``gnatbind`` to bind the program -and ``gnatlink`` to link it. The -argument to both ``gnatbind`` and ``gnatlink`` is the name of the -:file:`ALI` file, but the default extension of :file:`.ali` can -be omitted. This means that in the most common case, the argument -is simply the name of the main program: - -.. code-block:: sh - - $ gnatbind hello - $ gnatlink hello -A simpler method of carrying out these steps is to use ``gnatmake``, -a master program that invokes all the required -compilation, binding and linking tools in the correct order. In particular, -``gnatmake`` automatically recompiles any sources that have been -modified since they were last compiled, or sources that depend +To build an executable file, use either ``gnatmake`` or gprbuild with +the name of the main file: these tools are builders that will take care of +all the necessary build steps in the correct order. +In particular, these builders automatically recompile any sources that have +been modified since they were last compiled, or sources that depend on such modified sources, so that 'version skew' is avoided. .. index:: Version skew (avoided by ``gnatmake``) @@ -190,17 +207,6 @@ following three separate files: *gmain.adb* body of main program -To build an executable version of -this program, we could use four separate steps to compile, bind, and link -the program, as follows: - -.. code-block:: sh - - $ gcc -c gmain.adb - $ gcc -c greetings.adb - $ gnatbind gmain - $ gnatlink gmain - Note that there is no required order of compilation when using GNAT. In particular it is perfectly fine to compile the main program first. Also, it is not necessary to compile package specs in the case where @@ -212,66 +218,10 @@ generation, then use the :switch:`-gnatc` switch: $ gcc -c greetings.ads -gnatc -Although the compilation can be done in separate steps as in the -above example, in practice it is almost always more convenient -to use the ``gnatmake`` tool. All you need to know in this case -is the name of the main program's source file. The effect of the above four -commands can be achieved with a single one: +Although the compilation can be done in separate steps, in practice it is +almost always more convenient to use the ``gnatmake`` or ``gprbuild`` tools: .. code-block:: sh $ gnatmake gmain.adb -In the next section we discuss the advantages of using ``gnatmake`` in -more detail. - -.. _Using_the_gnatmake_Utility: - -Using the ``gnatmake`` Utility -============================== - -If you work on a program by compiling single components at a time using -``gcc``, you typically keep track of the units you modify. In order to -build a consistent system, you compile not only these units, but also any -units that depend on the units you have modified. -For example, in the preceding case, -if you edit :file:`gmain.adb`, you only need to recompile that file. But if -you edit :file:`greetings.ads`, you must recompile both -:file:`greetings.adb` and :file:`gmain.adb`, because both files contain -units that depend on :file:`greetings.ads`. - -``gnatbind`` will warn you if you forget one of these compilation -steps, so that it is impossible to generate an inconsistent program as a -result of forgetting to do a compilation. Nevertheless it is tedious and -error-prone to keep track of dependencies among units. -One approach to handle the dependency-bookkeeping is to use a -makefile. However, makefiles present maintenance problems of their own: -if the dependencies change as you change the program, you must make -sure that the makefile is kept up-to-date manually, which is also an -error-prone process. - -The ``gnatmake`` utility takes care of these details automatically. -Invoke it using either one of the following forms: - -.. code-block:: sh - - $ gnatmake gmain.adb - $ gnatmake gmain - -The argument is the name of the file containing the main program; -you may omit the extension. ``gnatmake`` -examines the environment, automatically recompiles any files that need -recompiling, and binds and links the resulting set of object files, -generating the executable file, :file:`gmain`. -In a large program, it -can be extremely helpful to use ``gnatmake``, because working out by hand -what needs to be recompiled can be difficult. - -Note that ``gnatmake`` takes into account all the Ada rules that -establish dependencies among units. These include dependencies that result -from inlining subprogram bodies, and from -generic instantiation. Unlike some other -Ada make tools, ``gnatmake`` does not rely on the dependencies that were -found by the compiler on a previous compilation, which may possibly -be wrong when sources change. ``gnatmake`` determines the exact set of -dependencies from scratch each time it is run. diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index 336b551..883f012 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -14,9 +14,6 @@ This chapter describes a number of utility programs: * :ref:`The_File_Cleanup_Utility_gnatclean` * :ref:`The_GNAT_Library_Browser_gnatls` - * :ref:`The_Cross-Referencing_Tools_gnatxref_and_gnatfind` - * :ref:`The_Ada_to_HTML_Converter_gnathtml` - * :ref:`The_Ada-to-XML_Converter_gnat2xml` * :ref:`The_Coding_Standard_Verifier_gnatcheck` * :ref:`The_GNAT_Metrics_Tool_gnatmetric` * :ref:`The_GNAT_Pretty_Printer_gnatpp` @@ -31,8 +28,6 @@ This chapter describes a number of utility programs: * :ref:`The_File_Cleanup_Utility_gnatclean` * :ref:`The_GNAT_Library_Browser_gnatls` - * :ref:`The_Cross-Referencing_Tools_gnatxref_and_gnatfind` - * :ref:`The_Ada_to_HTML_Converter_gnathtml` Other GNAT utilities are described elsewhere in this manual: @@ -472,1299 +467,6 @@ building specialized scripts. /home/comar/local/adainclude/unchconv.ads -.. _The_Cross-Referencing_Tools_gnatxref_and_gnatfind: - -The Cross-Referencing Tools ``gnatxref`` and ``gnatfind`` -========================================================= - -.. index:: ! gnatxref -.. index:: ! gnatfind - -The compiler generates cross-referencing information (unless -you set the :switch:`-gnatx` switch), which are saved in the :file:`.ali` files. -This information indicates where in the source each entity is declared and -referenced. Note that entities in package Standard are not included, but -entities in all other predefined units are included in the output. - -Before using any of these two tools, you need to compile successfully your -application, so that GNAT gets a chance to generate the cross-referencing -information. - -The two tools ``gnatxref`` and ``gnatfind`` take advantage of this -information to provide the user with the capability to easily locate the -declaration and references to an entity. These tools are quite similar, -the difference being that ``gnatfind`` is intended for locating -definitions and/or references to a specified entity or entities, whereas -``gnatxref`` is oriented to generating a full report of all -cross-references. - -To use these tools, you must not compile your application using the -:switch:`-gnatx` switch on the ``gnatmake`` command line -(see :ref:`The_GNAT_Make_Program_gnatmake`). Otherwise, cross-referencing -information will not be generated. - -.. _gnatxref_Switches: - -``gnatxref`` Switches ---------------------- - -The command invocation for ``gnatxref`` is: - - :: - - $ gnatxref [ switches ] sourcefile1 [ sourcefile2 ... ] - -where - -``sourcefile1`` [, ``sourcefile2`` ...] - identify the source files for which a report is to be generated. The - ``with``\ ed units will be processed too. You must provide at least one file. - - These file names are considered to be regular expressions, so for instance - specifying :file:`source\*.adb` is the same as giving every file in the current - directory whose name starts with :file:`source` and whose extension is - :file:`adb`. - - You shouldn't specify any directory name, just base names. ``gnatxref`` - and ``gnatfind`` will be able to locate these files by themselves using - the source path. If you specify directories, no result is produced. - -The following switches are available for ``gnatxref``: - - -.. index:: --version (gnatxref) - -:switch:`--version` - Display copyright and version, then exit disregarding all other options. - - -.. index:: --help (gnatxref) - -:switch:`--help` - If :switch:`--version` was not used, display usage, then exit disregarding - all other options. - - -.. index:: -a (gnatxref) - -:switch:`-a` - If this switch is present, ``gnatfind`` and ``gnatxref`` will parse - the read-only files found in the library search path. Otherwise, these files - will be ignored. This option can be used to protect Gnat sources or your own - libraries from being parsed, thus making ``gnatfind`` and ``gnatxref`` - much faster, and their output much smaller. Read-only here refers to access - or permissions status in the file system for the current user. - - -.. index:: -aIDIR (gnatxref) - -:switch:`-aI{DIR}` - When looking for source files also look in directory DIR. The order in which - source file search is undertaken is the same as for ``gnatmake``. - - -.. index:: -aODIR (gnatxref) - -:switch:`aO{DIR}` - When -searching for library and object files, look in directory - DIR. The order in which library files are searched is the same as for - ``gnatmake``. - - -.. index:: -nostdinc (gnatxref) - -:switch:`-nostdinc` - Do not look for sources in the system default directory. - - -.. index:: -nostdlib (gnatxref) - -:switch:`-nostdlib` - Do not look for library files in the system default directory. - - -.. index:: --ext (gnatxref) - -:switch:`--ext={extension}` - Specify an alternate ali file extension. The default is ``ali`` and other - extensions (e.g. ``gli`` for C/C++ sources) may be specified via this switch. - Note that if this switch overrides the default, only the new extension will - be considered. - - -.. index:: --RTS (gnatxref) - -:switch:`--RTS={rts-path}` - Specifies the default location of the runtime library. Same meaning as the - equivalent ``gnatmake`` flag (:ref:`Switches_for_gnatmake`). - - -.. index:: -d (gnatxref) - -:switch:`-d` - If this switch is set ``gnatxref`` will output the parent type - reference for each matching derived types. - - -.. index:: -f (gnatxref) - -:switch:`-f` - If this switch is set, the output file names will be preceded by their - directory (if the file was found in the search path). If this switch is - not set, the directory will not be printed. - - -.. index:: -g (gnatxref) - -:switch:`-g` - If this switch is set, information is output only for library-level - entities, ignoring local entities. The use of this switch may accelerate - ``gnatfind`` and ``gnatxref``. - - -.. index:: -IDIR (gnatxref) - -:switch:`-I{DIR}` - Equivalent to :switch:`-aODIR -aIDIR`. - - -.. index:: -pFILE (gnatxref) - -:switch:`-p{FILE}` - Specify a configuration file to use to list the source and object directories. - - If a file is specified, then the content of the source directory and object - directory lines are added as if they had been specified respectively - by :switch:`-aI` and :switch:`-aO`. - - See :ref:`Configuration_Files_for_gnatxref_and_gnatfind` for the syntax - of this configuration file. - -:switch:`-u` - Output only unused symbols. This may be really useful if you give your - main compilation unit on the command line, as ``gnatxref`` will then - display every unused entity and 'with'ed package. - -:switch:`-v` - Instead of producing the default output, ``gnatxref`` will generate a - :file:`tags` file that can be used by vi. For examples how to use this - feature, see :ref:`Examples_of_gnatxref_Usage`. The tags file is output - to the standard output, thus you will have to redirect it to a file. - -All these switches may be in any order on the command line, and may even -appear after the file names. They need not be separated by spaces, thus -you can say ``gnatxref -ag`` instead of ``gnatxref -a -g``. - -.. _gnatfind_Switches: - -``gnatfind`` Switches ---------------------- - -The command invocation for ``gnatfind`` is: - - :: - - $ gnatfind [ switches ] pattern[:sourcefile[:line[:column]]] - [file1 file2 ...] - -with the following iterpretation of the command arguments: - -*pattern* - An entity will be output only if it matches the regular expression found - in *pattern*, see :ref:`Regular_Expressions_in_gnatfind_and_gnatxref`. - - Omitting the pattern is equivalent to specifying ``*``, which - will match any entity. Note that if you do not provide a pattern, you - have to provide both a sourcefile and a line. - - Entity names are given in Latin-1, with uppercase/lowercase equivalence - for matching purposes. At the current time there is no support for - 8-bit codes other than Latin-1, or for wide characters in identifiers. - -*sourcefile* - ``gnatfind`` will look for references, bodies or declarations - of symbols referenced in :file:`sourcefile`, at line ``line`` - and column ``column``. See :ref:`Examples_of_gnatfind_Usage` - for syntax examples. - -*line* - A decimal integer identifying the line number containing - the reference to the entity (or entities) to be located. - - -*column* - A decimal integer identifying the exact location on the - line of the first character of the identifier for the - entity reference. Columns are numbered from 1. - - -*file1 file2 ...* - The search will be restricted to these source files. If none are given, then - the search will be conducted for every library file in the search path. - These files must appear only after the pattern or sourcefile. - - These file names are considered to be regular expressions, so for instance - specifying :file:`source\*.adb` is the same as giving every file in the current - directory whose name starts with :file:`source` and whose extension is - :file:`adb`. - - The location of the spec of the entity will always be displayed, even if it - isn't in one of :file:`file1`, :file:`file2`, ... The - occurrences of the entity in the separate units of the ones given on the - command line will also be displayed. - - Note that if you specify at least one file in this part, ``gnatfind`` may - sometimes not be able to find the body of the subprograms. - -At least one of 'sourcefile' or 'pattern' has to be present on -the command line. - -The following switches are available: - -.. index:: --version (gnatfind) - -:switch:`--version` - Display copyright and version, then exit disregarding all other options. - - -.. index:: --help (gnatfind) - -:switch:`--help` - If :switch:`--version` was not used, display usage, then exit disregarding - all other options. - - -.. index:: -a (gnatfind) - -:switch:`-a` - If this switch is present, ``gnatfind`` and ``gnatxref`` will parse - the read-only files found in the library search path. Otherwise, these files - will be ignored. This option can be used to protect Gnat sources or your own - libraries from being parsed, thus making ``gnatfind`` and ``gnatxref`` - much faster, and their output much smaller. Read-only here refers to access - or permission status in the file system for the current user. - - -.. index:: -aIDIR (gnatfind) - -:switch:`-aI{DIR}` - When looking for source files also look in directory DIR. The order in which - source file search is undertaken is the same as for ``gnatmake``. - - -.. index:: -aODIR (gnatfind) - -:switch:`-aO{DIR}` - When searching for library and object files, look in directory - DIR. The order in which library files are searched is the same as for - ``gnatmake``. - - -.. index:: -nostdinc (gnatfind) - -:switch:`-nostdinc` - Do not look for sources in the system default directory. - - -.. index:: -nostdlib (gnatfind) - -:switch:`-nostdlib` - Do not look for library files in the system default directory. - - -.. index:: --ext (gnatfind) - -:switch:`--ext={extension}` - Specify an alternate ali file extension. The default is ``ali`` and other - extensions may be specified via this switch. Note that if this switch - overrides the default, only the new extension will be considered. - - -.. index:: --RTS (gnatfind) - -:switch:`--RTS={rts-path}` - Specifies the default location of the runtime library. Same meaning as the - equivalent ``gnatmake`` flag (:ref:`Switches_for_gnatmake`). - - -.. index:: -d (gnatfind) - -:switch:`-d` - If this switch is set, then ``gnatfind`` will output the parent type - reference for each matching derived types. - - -.. index:: -e (gnatfind) - -:switch:`-e` - By default, ``gnatfind`` accept the simple regular expression set for - ``pattern``. If this switch is set, then the pattern will be - considered as full Unix-style regular expression. - - -.. index:: -f (gnatfind) - -:switch:`-f` - If this switch is set, the output file names will be preceded by their - directory (if the file was found in the search path). If this switch is - not set, the directory will not be printed. - - -.. index:: -g (gnatfind) - -:switch:`-g` - If this switch is set, information is output only for library-level - entities, ignoring local entities. The use of this switch may accelerate - ``gnatfind`` and ``gnatxref``. - - -.. index:: -IDIR (gnatfind) - -:switch:`-I{DIR}` - Equivalent to :switch:`-aODIR -aIDIR`. - - -.. index:: -pFILE (gnatfind) - -:switch:`-p{FILE}` - Specify a configuration file to use to list the source and object directories. - - If a file is specified, then the content of the source directory and object - directory lines are added as if they had been specified respectively - by :switch:`-aI` and :switch:`-aO`. - - See :ref:`Configuration_Files_for_gnatxref_and_gnatfind` for the syntax - of this configuration file. - -.. index:: -r (gnatfind) - -:switch:`-r` - By default, ``gnatfind`` will output only the information about the - declaration, body or type completion of the entities. If this switch is - set, the ``gnatfind`` will locate every reference to the entities in - the files specified on the command line (or in every file in the search - path if no file is given on the command line). - - -.. index:: -s (gnatfind) - -:switch:`-s` - If this switch is set, then ``gnatfind`` will output the content - of the Ada source file lines were the entity was found. - - -.. index:: -t (gnatfind) - -:switch:`-t` - If this switch is set, then ``gnatfind`` will output the type hierarchy for - the specified type. It act like -d option but recursively from parent - type to parent type. When this switch is set it is not possible to - specify more than one file. - - -All these switches may be in any order on the command line, and may even -appear after the file names. They need not be separated by spaces, thus -you can say ``gnatxref -ag`` instead of -``gnatxref -a -g``. - -As stated previously, ``gnatfind`` will search in every directory in the -search path. You can force it to look only in the current directory if -you specify ``*`` at the end of the command line. - -.. _Configuration_Files_for_gnatxref_and_gnatfind: - -Configuration Files for ``gnatxref`` and ``gnatfind`` ------------------------------------------------------ - -Configuration files are used by ``gnatxref`` and ``gnatfind`` to specify -the list of source and object directories to consider. They can be -specified via the :switch:`-p` switch. - -The following lines can be included, in any order in the file: - -* *src_dir=DIR* - [default: ``"./"``]. - Specifies a directory where to look for source files. Multiple ``src_dir`` - lines can be specified and they will be searched in the order they - are specified. - -* *obj_dir=DIR* - [default: ``"./"``]. - Specifies a directory where to look for object and library files. Multiple - ``obj_dir`` lines can be specified, and they will be searched in the order - they are specified - -Any other line will be silently ignored. - -.. _Regular_Expressions_in_gnatfind_and_gnatxref: - -Regular Expressions in ``gnatfind`` and ``gnatxref`` ----------------------------------------------------- - -As specified in the section about ``gnatfind``, the pattern can be a -regular expression. Two kinds of regular expressions -are recognized: - -* *Globbing pattern* - These are the most common regular expression. They are the same as are - generally used in a Unix shell command line, or in a DOS session. - - Here is a more formal grammar: - - :: - - regexp ::= term - term ::= elmt -- matches elmt - term ::= elmt elmt -- concatenation (elmt then elmt) - term ::= * -- any string of 0 or more characters - term ::= ? -- matches any character - term ::= [char {char}] -- matches any character listed - term ::= [char - char] -- matches any character in range - -* *Full regular expression* - The second set of regular expressions is much more powerful. This is the - type of regular expressions recognized by utilities such as ``grep``. - - The following is the form of a regular expression, expressed in same BNF - style as is found in the Ada Reference Manual: - - :: - - regexp ::= term {| term} -- alternation (term or term ...) - - term ::= item {item} -- concatenation (item then item) - - item ::= elmt -- match elmt - item ::= elmt * -- zero or more elmt's - item ::= elmt + -- one or more elmt's - item ::= elmt ? -- matches elmt or nothing - - elmt ::= nschar -- matches given character - elmt ::= [nschar {nschar}] -- matches any character listed - elmt ::= [^ nschar {nschar}] -- matches any character not listed - elmt ::= [char - char] -- matches chars in given range - elmt ::= \\ char -- matches given character - elmt ::= . -- matches any single character - elmt ::= ( regexp ) -- parens used for grouping - - char ::= any character, including special characters - nschar ::= any character except ()[].*+?^ - - Here are a few examples: - - ``abcde|fghi`` - will match any of the two strings ``abcde`` and ``fghi``, - - ``abc*d`` - will match any string like ``abd``, ``abcd``, ``abccd``, - ``abcccd``, and so on, - - ``[a-z]+`` - will match any string which has only lowercase characters in it (and at - least one character. - - -.. _Examples_of_gnatxref_Usage: - -Examples of ``gnatxref`` Usage ------------------------------- - -General Usage -^^^^^^^^^^^^^ - -For the following examples, we will consider the following units: - - .. code-block:: ada - - main.ads: - 1: with Bar; - 2: package Main is - 3: procedure Foo (B : in Integer); - 4: C : Integer; - 5: private - 6: D : Integer; - 7: end Main; - - main.adb: - 1: package body Main is - 2: procedure Foo (B : in Integer) is - 3: begin - 4: C := B; - 5: D := B; - 6: Bar.Print (B); - 7: Bar.Print (C); - 8: end Foo; - 9: end Main; - - bar.ads: - 1: package Bar is - 2: procedure Print (B : Integer); - 3: end bar; - -The first thing to do is to recompile your application (for instance, in -that case just by doing a ``gnatmake main``, so that GNAT generates -the cross-referencing information. -You can then issue any of the following commands: - - * ``gnatxref main.adb`` - ``gnatxref`` generates cross-reference information for main.adb - and every unit 'with'ed by main.adb. - - The output would be: - - :: - - B Type: Integer - Decl: bar.ads 2:22 - B Type: Integer - Decl: main.ads 3:20 - Body: main.adb 2:20 - Ref: main.adb 4:13 5:13 6:19 - Bar Type: Unit - Decl: bar.ads 1:9 - Ref: main.adb 6:8 7:8 - main.ads 1:6 - C Type: Integer - Decl: main.ads 4:5 - Modi: main.adb 4:8 - Ref: main.adb 7:19 - D Type: Integer - Decl: main.ads 6:5 - Modi: main.adb 5:8 - Foo Type: Unit - Decl: main.ads 3:15 - Body: main.adb 2:15 - Main Type: Unit - Decl: main.ads 2:9 - Body: main.adb 1:14 - Print Type: Unit - Decl: bar.ads 2:15 - Ref: main.adb 6:12 7:12 - - - This shows that the entity ``Main`` is declared in main.ads, line 2, column 9, - its body is in main.adb, line 1, column 14 and is not referenced any where. - - The entity ``Print`` is declared in :file:`bar.ads`, line 2, column 15 and it - is referenced in :file:`main.adb`, line 6 column 12 and line 7 column 12. - - - * ``gnatxref package1.adb package2.ads`` - ``gnatxref`` will generates cross-reference information for - :file:`package1.adb`, :file:`package2.ads` and any other package ``with``\ ed by any - of these. - - -Using ``gnatxref`` with ``vi`` -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -``gnatxref`` can generate a tags file output, which can be used -directly from ``vi``. Note that the standard version of ``vi`` -will not work properly with overloaded symbols. Consider using another -free implementation of ``vi``, such as ``vim``. - - :: - - $ gnatxref -v gnatfind.adb > tags - - -The following command will generate the tags file for ``gnatfind`` itself -(if the sources are in the search path!): - - :: - - $ gnatxref -v gnatfind.adb > tags - -From ``vi``, you can then use the command :samp:`:tag {entity}` -(replacing ``entity`` by whatever you are looking for), and vi will -display a new file with the corresponding declaration of entity. - - -.. _Examples_of_gnatfind_Usage: - -Examples of ``gnatfind`` Usage ------------------------------- - -* ``gnatfind -f xyz:main.adb`` - Find declarations for all entities xyz referenced at least once in - main.adb. The references are search in every library file in the search - path. - - The directories will be printed as well (as the ``-f`` - switch is set) - - The output will look like: - - :: - - directory/main.ads:106:14: xyz <= declaration - directory/main.adb:24:10: xyz <= body - directory/foo.ads:45:23: xyz <= declaration - - I.e., one of the entities xyz found in main.adb is declared at - line 12 of main.ads (and its body is in main.adb), and another one is - declared at line 45 of foo.ads - -* ``gnatfind -fs xyz:main.adb`` - This is the same command as the previous one, but ``gnatfind`` will - display the content of the Ada source file lines. - - The output will look like: - - :: - - directory/main.ads:106:14: xyz <= declaration - procedure xyz; - directory/main.adb:24:10: xyz <= body - procedure xyz is - directory/foo.ads:45:23: xyz <= declaration - xyz : Integer; - - This can make it easier to find exactly the location your are looking - for. - - -* ``gnatfind -r "*x*":main.ads:123 foo.adb`` - Find references to all entities containing an x that are - referenced on line 123 of main.ads. - The references will be searched only in main.ads and foo.adb. - - -* ``gnatfind main.ads:123`` - Find declarations and bodies for all entities that are referenced on - line 123 of main.ads. - - This is the same as ``gnatfind "*":main.adb:123``` - -* ``gnatfind mydir/main.adb:123:45`` - Find the declaration for the entity referenced at column 45 in - line 123 of file main.adb in directory mydir. Note that it - is usual to omit the identifier name when the column is given, - since the column position identifies a unique reference. - - The column has to be the beginning of the identifier, and should not - point to any character in the middle of the identifier. - - -.. _The_Ada_to_HTML_Converter_gnathtml: - -The Ada to HTML Converter ``gnathtml`` -====================================== - -.. index:: ! gnathtml - -``gnathtml`` is a Perl script that allows Ada source files to be browsed using -standard Web browsers. For installation information, see :ref:`Installing_gnathtml`. - -Ada reserved keywords are highlighted in a bold font and Ada comments in -a blue font. Unless your program was compiled with the gcc :switch:`-gnatx` -switch to suppress the generation of cross-referencing information, user -defined variables and types will appear in a different color; you will -be able to click on any identifier and go to its declaration. - -.. _Invoking_gnathtml: - -Invoking ``gnathtml`` ---------------------- - -The command line is as follows: - - :: - - $ perl gnathtml.pl [ switches ] ada-files - -You can specify as many Ada files as you want. ``gnathtml`` will generate -an html file for every ada file, and a global file called :file:`index.htm`. -This file is an index of every identifier defined in the files. - -The following switches are available: - -.. index:: -83 (gnathtml) - -:samp:`83` - Only the Ada 83 subset of keywords will be highlighted. - -.. index:: -cc (gnathtml) - -:samp:`cc {color}` - This option allows you to change the color used for comments. The default - value is green. The color argument can be any name accepted by html. - -.. index:: -d (gnathtml) - -:samp:`d` - If the Ada files depend on some other files (for instance through - ``with`` clauses, the latter files will also be converted to html. - Only the files in the user project will be converted to html, not the files - in the run-time library itself. - -.. index:: -D (gnathtml) - -:samp:`D` - This command is the same as :switch:`-d` above, but ``gnathtml`` will - also look for files in the run-time library, and generate html files for them. - -.. index:: -ext (gnathtml) - -:samp:`ext {extension}` - This option allows you to change the extension of the generated HTML files. - If you do not specify an extension, it will default to :file:`htm`. - -.. index:: -f (gnathtml) - -:samp:`f` - By default, gnathtml will generate html links only for global entities - ('with'ed units, global variables and types,...). If you specify - :switch:`-f` on the command line, then links will be generated for local - entities too. - -.. index:: -l (gnathtml) - -:samp:`l {number}` - If this switch is provided and ``number`` is not 0, then - ``gnathtml`` will number the html files every ``number`` line. - -.. index:: -I (gnathtml) - -:samp:`I {dir}` - Specify a directory to search for library files (:file:`.ALI` files) and - source files. You can provide several -I switches on the command line, - and the directories will be parsed in the order of the command line. - -.. index:: -o (gnathtml) - -:samp:`o {dir}` - Specify the output directory for html files. By default, gnathtml will - saved the generated html files in a subdirectory named :file:`html/`. - -.. index:: -p (gnathtml) - -:samp:`p {file}` - If you are using Emacs and the most recent Emacs Ada mode, which provides - a full Integrated Development Environment for compiling, checking, - running and debugging applications, you may use :file:`.gpr` files - to give the directories where Emacs can find sources and object files. - - Using this switch, you can tell gnathtml to use these files. - This allows you to get an html version of your application, even if it - is spread over multiple directories. - -.. index:: -sc (gnathtml) - -:samp:`sc {color}` - This switch allows you to change the color used for symbol - definitions. - The default value is red. The color argument can be any name accepted by html. - -.. index:: -t (gnathtml) - -:samp:`t {file}` - This switch provides the name of a file. This file contains a list of - file names to be converted, and the effect is exactly as though they had - appeared explicitly on the command line. This - is the recommended way to work around the command line length limit on some - systems. - -.. _Installing_gnathtml: - -Installing ``gnathtml`` ------------------------ - -``Perl`` needs to be installed on your machine to run this script. -``Perl`` is freely available for almost every architecture and -operating system via the Internet. - -On Unix systems, you may want to modify the first line of the script -``gnathtml``, to explicitly specify where Perl -is located. The syntax of this line is: - - :: - - #!full_path_name_to_perl - -Alternatively, you may run the script using the following command line: - - :: - - $ perl gnathtml.pl [ switches ] files - - - - -.. -- +---------------------------------------------------------------------+ -.. -- | The following sections are present only in the PRO and GPL editions | -.. -- +---------------------------------------------------------------------+ - -.. only:: PRO or GPL - - .. _The_Ada-to-XML_converter_gnat2xml: - - The Ada-to-XML converter ``gnat2xml`` - ===================================== - - .. index:: ! gnat2xml - .. index:: XML generation - - The ``gnat2xml`` tool is an ASIS-based utility that converts - Ada source code into XML. - - ``gnat2xml`` is a project-aware tool - (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of - the project-related switches). The project file package that can specify - ``gnat2xml`` switches is named ``gnat2xml``. - - .. _Switches_for_``gnat2xml``: - - Switches for ``gnat2xml`` - ------------------------- - - ``gnat2xml`` takes Ada source code as input, and produces XML - that conforms to the schema. - - Usage: - - :: - - $ gnat2xml [options] filenames [-files filename] [-cargs gcc_switches] - - Options: - - :switch:`--help` - Generate usage information and quit, ignoring all other options - - :switch:`-h` - Same as ``--help`` - - :switch:`--version` - Print version and quit, ignoring all other options - - :switch:`-P{file}` - indicates the name of the project file that describes - the set of sources to be processed. The exact set of argument - sources depends on other options specified, see below. - - :switch:`-U` - If a project file is specified and no argument source is explicitly - specified, process all the units of the closure of the argument project. - Otherwise this option has no effect. - - :switch:`-U {main_unit}` - If a project file is specified and no argument source - is explicitly specified (either directly or by means of :switch:`-files` - option), process the closure of units rooted at ``main_unit``. - Otherwise this option has no effect. - - :switch:`-X{name}={value}` - Indicates that external variable ``name`` in - the argument project has the value ``value``. Has no effect if no - project is specified. - - :switch:`--RTS={rts-path}` - Specifies the default location of the runtime - library. Same meaning as the equivalent ``gnatmake`` flag - (:ref:`Switches_for_gnatmake`). - - :switch:`--incremental` - Incremental processing on a per-file basis. Source files are - only processed if they have been modified, or if files they depend - on have been modified. This is similar to the way gnatmake/gprbuild - only compiles files that need to be recompiled. A project file - is required in this mode. - - :switch:`-j{n}` - In :switch:`--incremental` mode, use ``n`` ``gnat2xml`` - processes to perform XML generation in parallel. If ``n`` is 0, then - the maximum number of parallel tree creations is the number of core - processors on the platform. - - :switch:`--output-dir={dir}` - Generate one .xml file for each Ada source file, in - directory :file:`dir`. (Default is to generate the XML to standard - output.) - - :switch:`-I{include-dir}` - Directories to search for dependencies. - You can also set the ADA_INCLUDE_PATH environment variable for this. - - :switch:`--compact` - Debugging version, with interspersed source, and a more - compact representation of "sloc". This version does not conform - to any schema. - - :switch:`--rep-clauses` - generate representation clauses (see :ref:`Generating_Representation_Clauses`). - - :switch:`-files={filename}` - Take as arguments the files listed in text file ``file``. - Text file ``file`` may contain empty lines that are ignored. - Each nonempty line should contain the name of an existing file. - Several such switches may be specified simultaneously. - - :switch:`--ignore={filename}` - Do not process the sources listed in a specified file. This option cannot - be used in incremental mode. - - :switch:`-q` - Quiet - - :switch:`-v` - Verbose - - :switch:`-cargs` ... - Options to pass to gcc - - If a project file is specified and no argument source is explicitly - specified, and no :switch:`-U` is specified, then the set of processed - sources is all the immediate units of the argument project. - - Example: - - :: - - $ gnat2xml -v -output-dir=xml-files *.ad[sb] - - The above will create \*.xml files in the :file:`xml-files` subdirectory. - For example, if there is an Ada package Mumble.Dumble, whose spec and - body source code lives in mumble-dumble.ads and mumble-dumble.adb, - the above will produce xml-files/mumble-dumble.ads.xml and - xml-files/mumble-dumble.adb.xml. - - .. _Other_Programs: - - Other Programs - -------------- - - The distribution includes two other programs that are related to - ``gnat2xml``: - - ``gnat2xsd`` is the schema generator, which generates the schema - to standard output, based on the structure of Ada as encoded by - ASIS. You don't need to run ``gnat2xsd`` in order to use - ``gnat2xml``. To generate the schema, type: - - - :: - - $ gnat2xsd > ada-schema.xsd - - - ``gnat2xml`` generates XML files that will validate against - :file:`ada-schema.xsd`. - - ``xml2gnat`` is a back-translator that translates the XML back into - Ada source code. This is primarily for the purpose of testing - ``gnat2xml``, rather than for users. The Ada generated by ``xml2gnat`` - has identical semantics to the original Ada code passed to - ``gnat2xml``. It is not textually identical, however --- for example, - no attempt is made to preserve the original indentation. - - The ``xml2gnat`` command line contains a list of the same Ada files - passed to gnat2xml (not the names of xml files). The xml files are - assumed to be in an 'xml' subdirectory of the directory in which the - Ada source files are. So for example, if the Ada source file is - some/dir/mumble.adb, then the xml file is found in - some/dir/xml/mumble.adb.xml. You should use the :switch:`--output-dir` - switch of ``gnat2xml`` to tell it to generate the output in the xml - subdirectory, so ``xml2gnat`` can find it. - - Output goes into subdirectories "generated_ada" and "self_rep" of the - output directory, which is the current directory by default, but can - be overridden with --output-dir=dir on the command line. - - .. _Structure_of_the_XML: - - Structure of the XML - -------------------- - - The primary documentation for the structure of the XML generated by - ``gnat2xml`` is the schema (see ``gnat2xsd`` above). The - following documentation gives additional details needed to understand - the schema and therefore the XML. - - The elements listed under Defining Occurrences, Usage Occurrences, and - Other Elements represent the syntactic structure of the Ada program. - Element names are given in lower case, with the corresponding element - type Capitalized_Like_This. The element and element type names are - derived directly from the ASIS enumeration type Flat_Element_Kinds, - declared in Asis.Extensions.Flat_Kinds, with the leading ``An_`` or ``A_`` - removed. For example, the ASIS enumeration literal - An_Assignment_Statement corresponds to the XML element - assignment_statement of XML type Assignment_Statement. - - To understand the details of the schema and the corresponding XML, it is - necessary to understand the ASIS standard, as well as the GNAT-specific - extension to ASIS. - - A defining occurrence is an identifier (or character literal or operator - symbol) declared by a declaration. A usage occurrence is an identifier - (or ...) that references such a declared entity. For example, in: - - - .. code-block:: ada - - type T is range 1..10; - X, Y : constant T := 1; - - - The first 'T' is the defining occurrence of a type. The 'X' is the - defining occurrence of a constant, as is the 'Y', and the second 'T' is - a usage occurrence referring to the defining occurrence of T. - - Each element has a 'sloc' (source location), and subelements for each - syntactic subtree, reflecting the Ada grammar as implemented by ASIS. - The types of subelements are as defined in the ASIS standard. For - example, for the right-hand side of an assignment_statement we have - the following comment in asis-statements.ads: - - .. code-block:: ada - - ------------------------------------------------------------------------------ - -- 18.3 function Assignment_Expression - ------------------------------------------------------------------------------ - - function Assignment_Expression - (Statement : Asis.Statement) - return Asis.Expression; - - ------------------------------------------------------------------------------ - ... - -- Returns the expression from the right hand side of the assignment. - ... - -- Returns Element_Kinds: - -- An_Expression - - - The corresponding sub-element of type Assignment_Statement is: - - :: - - <xsd:element name="assignment_expression_q" type="Expression_Class"/> - - where Expression_Class is defined by an xsd:choice of all the - various kinds of expression. - - The 'sloc' of each element indicates the starting and ending line and - column numbers. Column numbers are character counts; that is, a tab - counts as 1, not as however many spaces it might expand to. - - Subelements of type Element have names ending in '_q' (for ASIS - "Query"), and those of type Element_List end in '_ql' - ("Query returning List"). - - Some subelements are 'Boolean'. For example, Private_Type_Definition - has has_abstract_q and has_limited_q, to indicate whether those - keywords are present, as in ``type T is abstract limited private;``. - False is represented by a Nil_Element. True is represented - by an element type specific to that query (for example, Abstract and - Limited). - - The root of the tree is a Compilation_Unit, with attributes: - - * unit_kind, unit_class, and unit_origin. These are strings that match the - enumeration literals of types Unit_Kinds, Unit_Classes, and Unit_Origins - in package Asis. - - * unit_full_name is the full expanded name of the unit, starting from a - root library unit. So for ``package P.Q.R is ...``, - ``unit_full_name="P.Q.R"``. Same for ``separate (P.Q) package R is ...``. - - * def_name is the same as unit_full_name for library units; for subunits, - it is just the simple name. - - * source_file is the name of the Ada source file. For example, for - the spec of ``P.Q.R``, ``source_file="p-q-r.ads"``. This allows one to - interpret the source locations --- the 'sloc' of all elements - within this Compilation_Unit refers to line and column numbers - within the named file. - - Defining occurrences have these attributes: - - * def_name is the simple name of the declared entity, as written in the Ada - source code. - - * def is a unique URI of the form: - - :: - - ada://kind/fully/qualified/name - - where: - - * kind indicates the kind of Ada entity being declared (see below), and - - * fully/qualified/name, is the fully qualified name of the Ada - entity, with each of 'fully', 'qualified', and 'name' being - mangled for uniqueness. We do not document the mangling - algorithm, which is subject to change; we just guarantee that the - names are unique in the face of overloading. - - * type is the type of the declared object, or ``null`` for - declarations of things other than objects. - - Usage occurrences have these attributes: - - * ref_name is the same as the def_name of the corresponding defining - occurrence. This attribute is not of much use, because of - overloading; use ref for lookups, instead. - - * ref is the same as the def of the corresponding defining - occurrence. - - In summary, ``def_name`` and ``ref_name`` are as in the source - code of the declaration, possibly overloaded, whereas ``def`` and - ``ref`` are unique-ified. - - Literal elements have this attribute: - - * lit_val is the value of the literal as written in the source text, - appropriately escaped (e.g. ``"`` |rightarrow| ``"``). This applies - only to numeric and string literals. Enumeration literals in Ada are - not really "literals" in the usual sense; they are usage occurrences, - and have ref_name and ref as described above. Note also that string - literals used as operator symbols are treated as defining or usage - occurrences, not as literals. - - Elements that can syntactically represent names and expressions (which - includes usage occurrences, plus function calls and so forth) have this - attribute: - - * type. If the element represents an expression or the name of an object, - 'type' is the 'def' for the defining occurrence of the type of that - expression or name. Names of other kinds of entities, such as package - names and type names, do not have a type in Ada; these have type="null" - in the XML. - - Pragma elements have this attribute: - - * pragma_name is the name of the pragma. For language-defined pragmas, the - pragma name is redundant with the element kind (for example, an - assert_pragma element necessarily has pragma_name="Assert"). However, all - implementation-defined pragmas are lumped together in ASIS as a single - element kind (for example, the GNAT-specific pragma Unreferenced is - represented by an implementation_defined_pragma element with - pragma_name="Unreferenced"). - - Defining occurrences of formal parameters and generic formal objects have this - attribute: - - * mode indicates that the parameter is of mode 'in', 'in out', or 'out'. - - All elements other than Not_An_Element have this attribute: - - * checks is a comma-separated list of run-time checks that are needed - for that element. The possible checks are: do_accessibility_check, - do_discriminant_check,do_division_check,do_length_check, - do_overflow_check,do_range_check,do_storage_check,do_tag_check. - - The "kind" part of the "def" and "ref" attributes is taken from the ASIS - enumeration type Flat_Declaration_Kinds, declared in - Asis.Extensions.Flat_Kinds, with the leading ``An_`` or ``A_`` removed, and - any trailing ``_Declaration`` or ``_Specification`` removed. Thus, the - possible kinds are as follows: - - :: - - ordinary_type - task_type - protected_type - incomplete_type - tagged_incomplete_type - private_type - private_extension - subtype - variable - constant - deferred_constant - single_task - single_protected - integer_number - real_number - enumeration_literal - discriminant - component - loop_parameter - generalized_iterator - element_iterator - procedure - function - parameter - procedure_body - function_body - return_variable - return_constant - null_procedure - expression_function - package - package_body - object_renaming - exception_renaming - package_renaming - procedure_renaming - function_renaming - generic_package_renaming - generic_procedure_renaming - generic_function_renaming - task_body - protected_body - entry - entry_body - entry_index - procedure_body_stub - function_body_stub - package_body_stub - task_body_stub - protected_body_stub - exception - choice_parameter - generic_procedure - generic_function - generic_package - package_instantiation - procedure_instantiation - function_instantiation - formal_object - formal_type - formal_incomplete_type - formal_procedure - formal_function - formal_package - formal_package_declaration_with_box - - .. _Generating_Representation_Clauses: - - Generating Representation Clauses - --------------------------------- - - If the :switch:`--rep-clauses` switch is given, ``gnat2xml`` will - generate representation clauses for certain types showing the - representation chosen by the compiler. The information is produced by - the ASIS 'Data Decomposition' facility --- see the - ``Asis.Data_Decomposition`` package for details. - - Not all types are supported. For example, ``Type_Model_Kind`` must - be ``A_Simple_Static_Model``. Types declared within generic units - have no representation. The clauses that are generated include - ``attribute_definition_clauses`` for ``Size`` and - ``Component_Size``, as well as - ``record_representation_clauses``. - - There is no guarantee that the generated representation clauses could - have actually come from legal Ada code; Ada has some restrictions that - are not necessarily obeyed by the generated clauses. - - The representation clauses are surrounded by comment elements to - indicate that they are automatically generated, something like this: - - :: - - <comment text="--gen+"> - ... - <attribute_definition_clause> - ... - <comment text="--gen-"> - ... - - .. only:: PRO or GPL .. _The_Coding_Standard_Verifier_gnatcheck: diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 8650542..bf839a5 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -423,6 +423,7 @@ package body Einfo is -- Never_Set_In_Source Flag115 -- Is_Visible_Lib_Unit Flag116 -- Is_Unchecked_Union Flag117 + -- Is_CUDA_Kernel Flag118 -- Has_Convention_Pragma Flag119 -- Has_Primitive_Operations Flag120 @@ -725,17 +726,17 @@ package body Einfo is function Access_Disp_Table (Id : E) return L is begin - pragma Assert (Ekind_In (Id, E_Record_Subtype, - E_Record_Type, - E_Record_Type_With_Private)); + pragma Assert (Ekind (Id) in E_Record_Subtype + | E_Record_Type + | E_Record_Type_With_Private); return Elist16 (Implementation_Base_Type (Id)); end Access_Disp_Table; function Access_Disp_Table_Elab_Flag (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Record_Subtype, - E_Record_Type, - E_Record_Type_With_Private)); + pragma Assert (Ekind (Id) in E_Record_Subtype + | E_Record_Type + | E_Record_Type_With_Private); return Node30 (Implementation_Base_Type (Id)); end Access_Disp_Table_Elab_Flag; @@ -747,19 +748,19 @@ package body Einfo is function Activation_Record_Component (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Constant, - E_In_Parameter, - E_In_Out_Parameter, - E_Loop_Parameter, - E_Out_Parameter, - E_Variable)); + pragma Assert (Ekind (Id) in E_Constant + | E_In_Parameter + | E_In_Out_Parameter + | E_Loop_Parameter + | E_Out_Parameter + | E_Variable); return Node31 (Id); end Activation_Record_Component; function Actual_Subtype (Id : E) return E is begin pragma Assert - (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) + (Ekind (Id) in E_Constant | E_Variable | E_Generic_In_Out_Parameter or else Is_Formal (Id)); return Node17 (Id); end Actual_Subtype; @@ -780,10 +781,10 @@ package body Einfo is begin pragma Assert (Is_Type (Id) or else Is_Formal (Id) - or else Ekind_In (Id, E_Loop_Parameter, - E_Constant, - E_Exception, - E_Variable)); + or else Ekind (Id) in E_Loop_Parameter + | E_Constant + | E_Exception + | E_Variable); return Uint14 (Id); end Alignment; @@ -795,16 +796,16 @@ package body Einfo is function Anonymous_Masters (Id : E) return L is begin - pragma Assert (Ekind_In (Id, E_Function, - E_Package, - E_Procedure, - E_Subprogram_Body)); + pragma Assert (Ekind (Id) in E_Function + | E_Package + | E_Procedure + | E_Subprogram_Body); return Elist29 (Id); end Anonymous_Masters; function Anonymous_Object (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Protected_Type, E_Task_Type)); + pragma Assert (Ekind (Id) in E_Protected_Type | E_Task_Type); return Node30 (Id); end Anonymous_Object; @@ -871,7 +872,7 @@ package body Einfo is function BIP_Initialization_Call (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); return Node29 (Id); end BIP_Initialization_Call; @@ -905,19 +906,19 @@ package body Einfo is function Cloned_Subtype (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype)); + pragma Assert (Ekind (Id) in E_Record_Subtype | E_Class_Wide_Subtype); return Node16 (Id); end Cloned_Subtype; function Component_Bit_Offset (Id : E) return U is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); return Uint11 (Id); end Component_Bit_Offset; function Component_Clause (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); return Node13 (Id); end Component_Clause; @@ -974,7 +975,7 @@ package body Einfo is function Corresponding_Record_Component (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); return Node21 (Id); end Corresponding_Record_Component; @@ -1146,8 +1147,7 @@ package body Einfo is function Dispatch_Table_Wrappers (Id : E) return L is begin - pragma Assert (Ekind_In (Id, E_Record_Type, - E_Record_Subtype)); + pragma Assert (Ekind (Id) in E_Record_Type | E_Record_Subtype); return Elist26 (Implementation_Base_Type (Id)); end Dispatch_Table_Wrappers; @@ -1165,14 +1165,14 @@ package body Einfo is function DT_Position (Id : E) return U is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + pragma Assert (Ekind (Id) in E_Function | E_Procedure and then Present (DTC_Entity (Id))); return Uint15 (Id); end DT_Position; function DTC_Entity (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Node16 (Id); end DTC_Entity; @@ -1187,7 +1187,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) + Ekind (Id) in E_Entry | E_Entry_Family | E_Package or else Is_Generic_Unit (Id)); return Node13 (Id); @@ -1198,7 +1198,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) + Ekind (Id) in E_Entry | E_Entry_Family | E_Package or else Is_Generic_Unit (Id)); return Flag174 (Id); @@ -1206,7 +1206,7 @@ package body Einfo is function Encapsulating_State (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Abstract_State, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Abstract_State | E_Constant | E_Variable); return Node32 (Id); end Encapsulating_State; @@ -1256,40 +1256,40 @@ package body Einfo is function Contains_Ignored_Ghost_Code (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Block, - E_Function, - E_Generic_Function, - E_Generic_Package, - E_Generic_Procedure, - E_Package, - E_Package_Body, - E_Procedure, - E_Subprogram_Body)); + (Ekind (Id) in E_Block + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Package + | E_Package_Body + | E_Procedure + | E_Subprogram_Body); return Flag279 (Id); end Contains_Ignored_Ghost_Code; function Contract (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent types - E_Task_Body, - E_Task_Type) + (Ekind (Id) in E_Protected_Type -- concurrent types + | E_Task_Body + | E_Task_Type or else - Ekind_In (Id, E_Constant, -- objects - E_Variable) + Ekind (Id) in E_Constant -- objects + | E_Variable or else - Ekind_In (Id, E_Entry, -- overloadable - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Operator, - E_Procedure, - E_Subprogram_Body) + Ekind (Id) in E_Entry -- overloadable + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Operator + | E_Procedure + | E_Subprogram_Body or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body) + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body or else Is_Type (Id) -- types or else @@ -1335,13 +1335,12 @@ package body Einfo is function Equivalent_Type (Id : E) return E is begin pragma Assert - (Ekind_In (Id, E_Class_Wide_Type, - E_Class_Wide_Subtype, - E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Access_Subprogram_Type, - E_Exception_Type)); + (Ekind (Id) in E_Class_Wide_Type + | E_Class_Wide_Subtype + | E_Access_Subprogram_Type + | E_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type + | E_Exception_Type); return Node18 (Id); end Equivalent_Type; @@ -1353,13 +1352,14 @@ package body Einfo is function Extra_Accessibility (Id : E) return E is begin pragma Assert - (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant)); + (Is_Formal (Id) or else Ekind (Id) in E_Variable | E_Constant); return Node13 (Id); end Extra_Accessibility; function Extra_Accessibility_Of_Result (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type)); + pragma Assert + (Ekind (Id) in E_Function | E_Operator | E_Subprogram_Type); return Node19 (Id); end Extra_Accessibility_Of_Result; @@ -1378,9 +1378,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind (Id) in E_Entry_Family + | E_Subprogram_Body + | E_Subprogram_Type); return Node28 (Id); end Extra_Formals; @@ -1404,7 +1404,7 @@ package body Einfo is function Finalizer (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); + pragma Assert (Ekind (Id) in E_Package | E_Package_Body); return Node28 (Id); end Finalizer; @@ -1680,7 +1680,7 @@ package body Einfo is function Has_Missing_Return (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); + pragma Assert (Ekind (Id) in E_Function | E_Generic_Function); return Flag142 (Id); end Has_Missing_Return; @@ -2014,23 +2014,23 @@ package body Einfo is function Ignore_SPARK_Mode_Pragmas (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Protected_Body, -- concurrent types - E_Protected_Type, - E_Task_Body, - E_Task_Type) + (Ekind (Id) in E_Protected_Body -- concurrent types + | E_Protected_Type + | E_Task_Body + | E_Task_Type or else - Ekind_In (Id, E_Entry, -- overloadable - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Operator, - E_Procedure, - E_Subprogram_Body) + Ekind (Id) in E_Entry -- overloadable + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Operator + | E_Procedure + | E_Subprogram_Body or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body)); + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body); return Flag301 (Id); end Ignore_SPARK_Mode_Pragmas; @@ -2076,7 +2076,7 @@ package body Einfo is function Initialization_Statements (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); return Node28 (Id); end Initialization_Statements; @@ -2154,7 +2154,7 @@ package body Einfo is function Is_Called (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Procedure, E_Function, E_Package)); + pragma Assert (Ekind (Id) in E_Procedure | E_Function | E_Package); return Flag102 (Id); end Is_Called; @@ -2235,9 +2235,15 @@ package body Einfo is return Flag74 (Id); end Is_CPP_Class; + function Is_CUDA_Kernel (Id : E) return B is + begin + pragma Assert (Ekind (Id) in E_Function | E_Procedure); + return Flag118 (Id); + end Is_CUDA_Kernel; + function Is_DIC_Procedure (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag132 (Id); end Is_DIC_Procedure; @@ -2307,7 +2313,7 @@ package body Einfo is function Is_Finalized_Transient (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable); return Flag252 (Id); end Is_Finalized_Transient; @@ -2328,7 +2334,7 @@ package body Einfo is function Is_Generic_Actual_Subprogram (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag274 (Id); end Is_Generic_Actual_Subprogram; @@ -2375,7 +2381,7 @@ package body Einfo is function Is_Ignored_Transient (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable); return Flag295 (Id); end Is_Ignored_Transient; @@ -2402,7 +2408,7 @@ package body Einfo is function Is_Initial_Condition_Procedure (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag302 (Id); end Is_Initial_Condition_Procedure; @@ -2413,7 +2419,7 @@ package body Einfo is function Is_Inlined_Always (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag1 (Id); end Is_Inlined_Always; @@ -2446,7 +2452,7 @@ package body Einfo is function Is_Invariant_Procedure (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag257 (Id); end Is_Invariant_Procedure; @@ -2548,7 +2554,7 @@ package body Einfo is function Is_Partial_Invariant_Procedure (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag292 (Id); end Is_Partial_Invariant_Procedure; @@ -2560,13 +2566,13 @@ package body Einfo is function Is_Predicate_Function (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag255 (Id); end Is_Predicate_Function; function Is_Predicate_Function_M (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag256 (Id); end Is_Predicate_Function_M; @@ -2583,7 +2589,7 @@ package body Einfo is function Is_Primitive_Wrapper (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag195 (Id); end Is_Primitive_Wrapper; @@ -2600,7 +2606,7 @@ package body Einfo is function Is_Private_Primitive (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Flag245 (Id); end Is_Private_Primitive; @@ -2786,7 +2792,7 @@ package body Einfo is function Last_Aggregate_Assignment (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); return Node30 (Id); end Last_Aggregate_Assignment; @@ -2897,7 +2903,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); + or else Ekind (Id) in E_Subprogram_Type | E_Entry_Family); return Flag22 (Id); end Needs_No_Actuals; @@ -2977,19 +2983,19 @@ package body Einfo is function Normalized_First_Bit (Id : E) return U is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); return Uint8 (Id); end Normalized_First_Bit; function Normalized_Position (Id : E) return U is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); return Uint14 (Id); end Normalized_Position; function Normalized_Position_Max (Id : E) return U is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); return Uint10 (Id); end Normalized_Position_Max; @@ -3002,14 +3008,14 @@ package body Einfo is function Optimize_Alignment_Space (Id : E) return B is begin pragma Assert - (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); + (Is_Type (Id) or else Ekind (Id) in E_Constant | E_Variable); return Flag241 (Id); end Optimize_Alignment_Space; function Optimize_Alignment_Time (Id : E) return B is begin pragma Assert - (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); + (Is_Type (Id) or else Ekind (Id) in E_Constant | E_Variable); return Flag242 (Id); end Optimize_Alignment_Time; @@ -3032,7 +3038,7 @@ package body Einfo is function Original_Record_Component (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Void | E_Component | E_Discriminant); return Node22 (Id); end Original_Record_Component; @@ -3067,7 +3073,7 @@ package body Einfo is function Part_Of_Constituents (Id : E) return L is begin - pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable); return Elist10 (Id); end Part_Of_Constituents; @@ -3091,18 +3097,17 @@ package body Einfo is function Postconditions_Proc (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure)); + pragma Assert + (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure); return Node14 (Id); end Postconditions_Proc; function Predicated_Parent (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Array_Subtype, - E_Record_Subtype, - E_Record_Subtype_With_Private)); + pragma Assert + (Ekind (Id) in E_Array_Subtype | + E_Record_Subtype | + E_Record_Subtype_With_Private); return Node38 (Id); end Predicated_Parent; @@ -3125,7 +3130,7 @@ package body Einfo is function Prival_Link (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); return Node20 (Id); end Prival_Link; @@ -3149,16 +3154,14 @@ package body Einfo is function Protected_Subprogram (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); return Node39 (Id); end Protected_Subprogram; function Protection_Object (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure)); + pragma Assert + (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure); return Node23 (Id); end Protection_Object; @@ -3208,20 +3211,19 @@ package body Einfo is function Related_Expression (Id : E) return N is begin - pragma Assert (Ekind (Id) in Type_Kind - or else Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in Type_Kind | E_Constant | E_Variable); return Node24 (Id); end Related_Expression; function Related_Instance (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); + pragma Assert (Ekind (Id) in E_Package | E_Package_Body); return Node15 (Id); end Related_Instance; function Related_Type (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Component | E_Constant | E_Variable); return Node27 (Id); end Related_Type; @@ -3325,7 +3327,7 @@ package body Einfo is function Size_Check_Code (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); return Node19 (Id); end Size_Check_Code; @@ -3348,51 +3350,51 @@ package body Einfo is function SPARK_Aux_Pragma (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent types - E_Task_Type) + (Ekind (Id) in E_Protected_Type -- concurrent types + | E_Task_Type or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body)); + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body); return Node41 (Id); end SPARK_Aux_Pragma; function SPARK_Aux_Pragma_Inherited (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent types - E_Task_Type) + (Ekind (Id) in E_Protected_Type -- concurrent types + | E_Task_Type or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body)); + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body); return Flag266 (Id); end SPARK_Aux_Pragma_Inherited; function SPARK_Pragma (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Constant, -- objects - E_Variable) + (Ekind (Id) in E_Constant -- objects + | E_Variable or else - Ekind_In (Id, E_Abstract_State, -- overloadable - E_Entry, - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Operator, - E_Procedure, - E_Subprogram_Body) + Ekind (Id) in E_Abstract_State -- overloadable + | E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Operator + | E_Procedure + | E_Subprogram_Body or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body) + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body or else - Ekind (Id) = E_Void -- special purpose + Ekind (Id) = E_Void -- special purpose or else - Ekind_In (Id, E_Protected_Body, -- types - E_Task_Body) + Ekind (Id) in E_Protected_Body -- types + | E_Task_Body or else Is_Type (Id)); return Node40 (Id); @@ -3401,27 +3403,27 @@ package body Einfo is function SPARK_Pragma_Inherited (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Constant, -- objects - E_Variable) + (Ekind (Id) in E_Constant -- objects + | E_Variable or else - Ekind_In (Id, E_Abstract_State, -- overloadable - E_Entry, - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Operator, - E_Procedure, - E_Subprogram_Body) + Ekind (Id) in E_Abstract_State -- overloadable + | E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Operator + | E_Procedure + | E_Subprogram_Body or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body) + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body or else - Ekind (Id) = E_Void -- special purpose + Ekind (Id) = E_Void -- special purpose or else - Ekind_In (Id, E_Protected_Body, -- types - E_Task_Body) + Ekind (Id) in E_Protected_Body -- types + | E_Task_Body or else Is_Type (Id)); return Flag265 (Id); @@ -3459,9 +3461,8 @@ package body Einfo is function Status_Flag_Or_Transient_Decl (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Constant, - E_Loop_Parameter, - E_Variable)); + pragma Assert + (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable); return Node15 (Id); end Status_Flag_Or_Transient_Decl; @@ -3552,7 +3553,7 @@ package body Einfo is function Thunk_Entity (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + pragma Assert (Ekind (Id) in E_Function | E_Procedure and then Is_Thunk (Id)); return Node31 (Id); end Thunk_Entity; @@ -3633,7 +3634,7 @@ package body Einfo is function Wrapped_Entity (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + pragma Assert (Ekind (Id) in E_Function | E_Procedure and then Is_Primitive_Wrapper (Id)); return Node27 (Id); end Wrapped_Entity; @@ -3797,6 +3798,12 @@ package body Einfo is return Ekind (Id) in Modular_Integer_Kind; end Is_Modular_Integer_Type; + function Is_Named_Access_Type (Id : E) return B is + begin + return Ekind (Id) in E_Access_Type .. + E_Access_Protected_Subprogram_Type; + end Is_Named_Access_Type; + function Is_Named_Number (Id : E) return B is begin return Ekind (Id) in Named_Kind; @@ -3932,16 +3939,15 @@ package body Einfo is procedure Set_Anonymous_Masters (Id : E; V : L) is begin - pragma Assert (Ekind_In (Id, E_Function, - E_Package, - E_Procedure, - E_Subprogram_Body)); + pragma Assert + (Ekind (Id) + in E_Function | E_Package | E_Procedure | E_Subprogram_Body); Set_Elist29 (Id, V); end Set_Anonymous_Masters; procedure Set_Anonymous_Object (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Protected_Type, E_Task_Type)); + pragma Assert (Ekind (Id) in E_Protected_Type | E_Task_Type); Set_Node30 (Id, V); end Set_Anonymous_Object; @@ -3968,19 +3974,20 @@ package body Einfo is procedure Set_Activation_Record_Component (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Constant, - E_In_Parameter, - E_In_Out_Parameter, - E_Loop_Parameter, - E_Out_Parameter, - E_Variable)); + pragma Assert + (Ekind (Id) in E_Constant + | E_In_Parameter + | E_In_Out_Parameter + | E_Loop_Parameter + | E_Out_Parameter + | E_Variable); Set_Node31 (Id, V); end Set_Activation_Record_Component; procedure Set_Actual_Subtype (Id : E; V : E) is begin pragma Assert - (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) + (Ekind (Id) in E_Constant | E_Variable | E_Generic_In_Out_Parameter or else Is_Formal (Id)); Set_Node17 (Id, V); end Set_Actual_Subtype; @@ -4001,10 +4008,10 @@ package body Einfo is begin pragma Assert (Is_Type (Id) or else Is_Formal (Id) - or else Ekind_In (Id, E_Loop_Parameter, - E_Constant, - E_Exception, - E_Variable)); + or else Ekind (Id) in E_Loop_Parameter + | E_Constant + | E_Exception + | E_Variable); Set_Uint14 (Id, V); end Set_Alignment; @@ -4049,7 +4056,7 @@ package body Einfo is procedure Set_BIP_Initialization_Call (Id : E; V : N) is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); Set_Node29 (Id, V); end Set_BIP_Initialization_Call; @@ -4090,19 +4097,19 @@ package body Einfo is procedure Set_Cloned_Subtype (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype)); + pragma Assert (Ekind (Id) in E_Record_Subtype | E_Class_Wide_Subtype); Set_Node16 (Id, V); end Set_Cloned_Subtype; procedure Set_Component_Bit_Offset (Id : E; V : U) is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); Set_Uint11 (Id, V); end Set_Component_Bit_Offset; procedure Set_Component_Clause (Id : E; V : N) is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); Set_Node13 (Id, V); end Set_Component_Clause; @@ -4121,46 +4128,46 @@ package body Einfo is procedure Set_Contains_Ignored_Ghost_Code (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Block, - E_Function, - E_Generic_Function, - E_Generic_Package, - E_Generic_Procedure, - E_Package, - E_Package_Body, - E_Procedure, - E_Subprogram_Body)); + (Ekind (Id) in E_Block + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Package + | E_Package_Body + | E_Procedure + | E_Subprogram_Body); Set_Flag279 (Id, V); end Set_Contains_Ignored_Ghost_Code; procedure Set_Contract (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent types - E_Task_Body, - E_Task_Type) + (Ekind (Id) in E_Protected_Type -- concurrent types + | E_Task_Body + | E_Task_Type or else - Ekind_In (Id, E_Constant, -- objects - E_Variable) + Ekind (Id) in E_Constant -- objects + | E_Variable or else - Ekind_In (Id, E_Entry, -- overloadable - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Operator, - E_Procedure, - E_Subprogram_Body) + Ekind (Id) in E_Entry -- overloadable + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Operator + | E_Procedure + | E_Subprogram_Body or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body) + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body or else - Is_Type (Id) -- types + Is_Type (Id) -- types or else - Ekind (Id) = E_Void); -- special purpose + Ekind (Id) = E_Void); -- special purpose Set_Node34 (Id, V); end Set_Contract; @@ -4206,13 +4213,13 @@ package body Einfo is procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Void, E_Subprogram_Body)); + pragma Assert (Ekind (Id) in E_Void | E_Subprogram_Body); Set_Node18 (Id, V); end Set_Corresponding_Protected_Entry; procedure Set_Corresponding_Record_Component (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); Set_Node21 (Id, V); end Set_Corresponding_Record_Component; @@ -4295,7 +4302,7 @@ package body Einfo is procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True) is begin pragma Assert - (Is_Subprogram (Id) or else Ekind_In (Id, E_Package, E_Package_Body)); + (Is_Subprogram (Id) or else Ekind (Id) in E_Package | E_Package_Body); Set_Flag50 (Id, V); end Set_Delay_Subprogram_Descriptors; @@ -4403,13 +4410,13 @@ package body Einfo is procedure Set_DT_Position (Id : E; V : U) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Uint15 (Id, V); end Set_DT_Position; procedure Set_DTC_Entity (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Node16 (Id, V); end Set_DTC_Entity; @@ -4424,7 +4431,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) + Ekind (Id) in E_Entry | E_Entry_Family | E_Package or else Is_Generic_Unit (Id)); Set_Node13 (Id, V); @@ -4435,7 +4442,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) + Ekind (Id) in E_Entry | E_Entry_Family | E_Package or else Is_Generic_Unit (Id)); Set_Flag174 (Id, V); @@ -4443,7 +4450,7 @@ package body Einfo is procedure Set_Encapsulating_State (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Abstract_State, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Abstract_State | E_Constant | E_Variable); Set_Node32 (Id, V); end Set_Encapsulating_State; @@ -4522,12 +4529,12 @@ package body Einfo is procedure Set_Equivalent_Type (Id : E; V : E) is begin pragma Assert - (Ekind_In (Id, E_Class_Wide_Type, - E_Class_Wide_Subtype, - E_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Access_Subprogram_Type, - E_Exception_Type)); + (Ekind (Id) in E_Class_Wide_Type + | E_Class_Wide_Subtype + | E_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type + | E_Access_Subprogram_Type + | E_Exception_Type); Set_Node18 (Id, V); end Set_Equivalent_Type; @@ -4539,13 +4546,14 @@ package body Einfo is procedure Set_Extra_Accessibility (Id : E; V : E) is begin pragma Assert - (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant)); + (Is_Formal (Id) or else Ekind (Id) in E_Variable | E_Constant); Set_Node13 (Id, V); end Set_Extra_Accessibility; procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type)); + pragma Assert + (Ekind (Id) in E_Function | E_Operator | E_Subprogram_Type); Set_Node19 (Id, V); end Set_Extra_Accessibility_Of_Result; @@ -4564,9 +4572,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind (Id) in E_Entry_Family + | E_Subprogram_Body + | E_Subprogram_Type); Set_Node28 (Id, V); end Set_Extra_Formals; @@ -4584,7 +4592,7 @@ package body Einfo is procedure Set_Finalizer (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); + pragma Assert (Ekind (Id) in E_Package | E_Package_Body); Set_Node28 (Id, V); end Set_Finalizer; @@ -4637,7 +4645,7 @@ package body Einfo is procedure Set_From_Limited_With (Id : E; V : B := True) is begin pragma Assert - (Is_Type (Id) or else Ekind_In (Id, E_Abstract_State, E_Package)); + (Is_Type (Id) or else Ekind (Id) in E_Abstract_State | E_Package); Set_Flag159 (Id, V); end Set_From_Limited_With; @@ -4799,10 +4807,8 @@ package body Einfo is procedure Set_Has_Expanded_Contract (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure)); + pragma Assert + (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure); Set_Flag240 (Id, V); end Set_Has_Expanded_Contract; @@ -4857,7 +4863,7 @@ package body Einfo is procedure Set_Has_Initial_Value (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter)); + pragma Assert (Ekind (Id) in E_Variable | E_Out_Parameter); Set_Flag219 (Id, V); end Set_Has_Initial_Value; @@ -4880,7 +4886,7 @@ package body Einfo is procedure Set_Has_Missing_Return (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); + pragma Assert (Ekind (Id) in E_Function | E_Generic_Function); Set_Flag142 (Id, V); end Set_Has_Missing_Return; @@ -4910,7 +4916,7 @@ package body Einfo is procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Entry, E_Entry_Family) + (Ekind (Id) in E_Entry | E_Entry_Family or else Is_Subprogram_Or_Generic_Subprogram (Id)); Set_Flag110 (Id, V); end Set_Has_Out_Or_In_Out_Parameter; @@ -5234,23 +5240,23 @@ package body Einfo is procedure Set_Ignore_SPARK_Mode_Pragmas (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Protected_Body, -- concurrent types - E_Protected_Type, - E_Task_Body, - E_Task_Type) + (Ekind (Id) in E_Protected_Body -- concurrent types + | E_Protected_Type + | E_Task_Body + | E_Task_Type or else - Ekind_In (Id, E_Entry, -- overloadable - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Operator, - E_Procedure, - E_Subprogram_Body) + Ekind (Id) in E_Entry -- overloadable + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Operator + | E_Procedure + | E_Subprogram_Body or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body)); + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body); Set_Flag301 (Id, V); end Set_Ignore_SPARK_Mode_Pragmas; @@ -5265,7 +5271,7 @@ package body Einfo is pragma Assert (Is_Internal (Id) and then Is_Hidden (Id) - and then (Ekind_In (Id, E_Procedure, E_Function))); + and then (Ekind (Id) in E_Procedure | E_Function)); Set_Node25 (Id, V); end Set_Interface_Alias; @@ -5297,7 +5303,7 @@ package body Einfo is -- an aggregate used as the initialization expression for an object -- declaration, and this occurs before the Ekind for the object is set. - pragma Assert (Ekind_In (Id, E_Void, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Void | E_Constant | E_Variable); Set_Node28 (Id, V); end Set_Initialization_Statements; @@ -5384,7 +5390,7 @@ package body Einfo is procedure Set_Is_Called (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Procedure, E_Function, E_Package)); + pragma Assert (Ekind (Id) in E_Procedure | E_Function | E_Package); Set_Flag102 (Id, V); end Set_Is_Called; @@ -5471,6 +5477,12 @@ package body Einfo is Set_Flag74 (Id, V); end Set_Is_CPP_Class; + procedure Set_Is_CUDA_Kernel (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) in E_Function | E_Procedure); + Set_Flag118 (Id, V); + end Set_Is_CUDA_Kernel; + procedure Set_Is_DIC_Procedure (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Procedure); @@ -5550,7 +5562,7 @@ package body Einfo is procedure Set_Is_Finalized_Transient (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable); Set_Flag252 (Id, V); end Set_Is_Finalized_Transient; @@ -5572,7 +5584,7 @@ package body Einfo is procedure Set_Is_Generic_Actual_Subprogram (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Flag274 (Id, V); end Set_Is_Generic_Actual_Subprogram; @@ -5600,7 +5612,7 @@ package body Einfo is procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Flag2 (Id, V); end Set_Is_Hidden_Non_Overridden_Subpgm; @@ -5620,7 +5632,7 @@ package body Einfo is procedure Set_Is_Ignored_Transient (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable); Set_Flag295 (Id, V); end Set_Is_Ignored_Transient; @@ -5647,7 +5659,7 @@ package body Einfo is procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Flag302 (Id, V); end Set_Is_Initial_Condition_Procedure; @@ -5658,7 +5670,7 @@ package body Einfo is procedure Set_Is_Inlined_Always (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Flag1 (Id, V); end Set_Is_Inlined_Always; @@ -5785,7 +5797,7 @@ package body Einfo is procedure Set_Is_Param_Block_Component_Type (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Void, E_General_Access_Type)); + pragma Assert (Ekind (Id) in E_Void | E_General_Access_Type); Set_Flag215 (Id, V); end Set_Is_Param_Block_Component_Type; @@ -5809,7 +5821,7 @@ package body Einfo is procedure Set_Is_Predicate_Function_M (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Flag256 (Id, V); end Set_Is_Predicate_Function_M; @@ -5826,7 +5838,7 @@ package body Einfo is procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Flag195 (Id, V); end Set_Is_Primitive_Wrapper; @@ -5843,7 +5855,7 @@ package body Einfo is procedure Set_Is_Private_Primitive (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Flag245 (Id, V); end Set_Is_Private_Primitive; @@ -5917,16 +5929,14 @@ package body Einfo is begin pragma Assert (Is_Type (Id) - or else Ekind_In (Id, E_Exception, - E_Variable, - E_Constant, - E_Void)); + or else + Ekind (Id) in E_Exception | E_Variable | E_Constant | E_Void); Set_Flag28 (Id, V); end Set_Is_Statically_Allocated; procedure Set_Is_Tag (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Component | E_Constant | E_Variable); Set_Flag78 (Id, V); end Set_Is_Tag; @@ -5983,7 +5993,7 @@ package body Einfo is procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable) + (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable or else Is_Formal (Id) or else Is_Type (Id)); Set_Flag283 (Id, V); @@ -6040,7 +6050,7 @@ package body Einfo is procedure Set_Last_Aggregate_Assignment (Id : E; V : N) is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); Set_Node30 (Id, V); end Set_Last_Aggregate_Assignment; @@ -6152,7 +6162,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); + or else Ekind (Id) in E_Subprogram_Type | E_Entry_Family); Set_Flag22 (Id, V); end Set_Needs_No_Actuals; @@ -6218,7 +6228,7 @@ package body Einfo is begin pragma Assert (Ekind (Id) in Incomplete_Kind - or else Ekind_In (Id, E_Abstract_State, E_Class_Wide_Type)); + or else Ekind (Id) in E_Abstract_State | E_Class_Wide_Type); Set_Node19 (Id, V); end Set_Non_Limited_View; @@ -6232,19 +6242,19 @@ package body Einfo is procedure Set_Normalized_First_Bit (Id : E; V : U) is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); Set_Uint8 (Id, V); end Set_Normalized_First_Bit; procedure Set_Normalized_Position (Id : E; V : U) is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); Set_Uint14 (Id, V); end Set_Normalized_Position; procedure Set_Normalized_Position_Max (Id : E; V : U) is begin - pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Component | E_Discriminant); Set_Uint10 (Id, V); end Set_Normalized_Position_Max; @@ -6257,14 +6267,14 @@ package body Einfo is procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is begin pragma Assert - (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); + (Is_Type (Id) or else Ekind (Id) in E_Constant | E_Variable); Set_Flag241 (Id, V); end Set_Optimize_Alignment_Space; procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is begin pragma Assert - (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); + (Is_Type (Id) or else Ekind (Id) in E_Constant | E_Variable); Set_Flag242 (Id, V); end Set_Optimize_Alignment_Time; @@ -6282,13 +6292,13 @@ package body Einfo is procedure Set_Original_Protected_Subprogram (Id : E; V : N) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Node41 (Id, V); end Set_Original_Protected_Subprogram; procedure Set_Original_Record_Component (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); + pragma Assert (Ekind (Id) in E_Void | E_Component | E_Discriminant); Set_Node22 (Id, V); end Set_Original_Record_Component; @@ -6305,7 +6315,7 @@ package body Einfo is procedure Set_Package_Instantiation (Id : E; V : N) is begin - pragma Assert (Ekind_In (Id, E_Void, E_Generic_Package, E_Package)); + pragma Assert (Ekind (Id) in E_Void | E_Generic_Package | E_Package); Set_Node26 (Id, V); end Set_Package_Instantiation; @@ -6323,7 +6333,7 @@ package body Einfo is procedure Set_Part_Of_Constituents (Id : E; V : L) is begin - pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable); Set_Elist10 (Id, V); end Set_Part_Of_Constituents; @@ -6347,18 +6357,16 @@ package body Einfo is procedure Set_Postconditions_Proc (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure)); + pragma Assert + (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure); Set_Node14 (Id, V); end Set_Postconditions_Proc; procedure Set_Predicated_Parent (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Array_Subtype, - E_Record_Subtype, - E_Record_Subtype_With_Private)); + pragma Assert (Ekind (Id) in E_Array_Subtype + | E_Record_Subtype + | E_Record_Subtype_With_Private); Set_Node38 (Id, V); end Set_Predicated_Parent; @@ -6382,7 +6390,7 @@ package body Einfo is procedure Set_Prival_Link (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); Set_Node20 (Id, V); end Set_Prival_Link; @@ -6411,16 +6419,16 @@ package body Einfo is procedure Set_Protected_Subprogram (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + pragma Assert (Ekind (Id) in E_Function | E_Procedure); Set_Node39 (Id, V); end Set_Protected_Subprogram; procedure Set_Protection_Object (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure)); + pragma Assert (Ekind (Id) in E_Entry + | E_Entry_Family + | E_Function + | E_Procedure); Set_Node23 (Id, V); end Set_Protection_Object; @@ -6470,20 +6478,20 @@ package body Einfo is procedure Set_Related_Expression (Id : E; V : N) is begin - pragma Assert (Ekind (Id) in Type_Kind - or else Ekind_In (Id, E_Constant, E_Variable, E_Void)); + pragma Assert + (Ekind (Id) in Type_Kind | E_Constant | E_Variable | E_Void); Set_Node24 (Id, V); end Set_Related_Expression; procedure Set_Related_Instance (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); + pragma Assert (Ekind (Id) in E_Package | E_Package_Body); Set_Node15 (Id, V); end Set_Related_Instance; procedure Set_Related_Type (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Component | E_Constant | E_Variable); Set_Node27 (Id, V); end Set_Related_Type; @@ -6591,7 +6599,7 @@ package body Einfo is procedure Set_Size_Check_Code (Id : E; V : N) is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind (Id) in E_Constant | E_Variable); Set_Node19 (Id, V); end Set_Size_Check_Code; @@ -6614,51 +6622,51 @@ package body Einfo is procedure Set_SPARK_Aux_Pragma (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent types - E_Task_Type) + (Ekind (Id) in E_Protected_Type -- concurrent types + | E_Task_Type or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body)); + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body); Set_Node41 (Id, V); end Set_SPARK_Aux_Pragma; procedure Set_SPARK_Aux_Pragma_Inherited (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent types - E_Task_Type) + (Ekind (Id) in E_Protected_Type -- concurrent types + | E_Task_Type or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body)); + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body); Set_Flag266 (Id, V); end Set_SPARK_Aux_Pragma_Inherited; procedure Set_SPARK_Pragma (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Constant, -- objects - E_Variable) + (Ekind (Id) in E_Constant -- objects + | E_Variable or else - Ekind_In (Id, E_Abstract_State, -- overloadable - E_Entry, - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Operator, - E_Procedure, - E_Subprogram_Body) + Ekind (Id) in E_Abstract_State -- overloadable + | E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Operator + | E_Procedure + | E_Subprogram_Body or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body) + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body or else - Ekind (Id) = E_Void -- special purpose + Ekind (Id) = E_Void -- special purpose or else - Ekind_In (Id, E_Protected_Body, -- types - E_Task_Body) + Ekind (Id) in E_Protected_Body -- types + | E_Task_Body or else Is_Type (Id)); Set_Node40 (Id, V); @@ -6667,27 +6675,27 @@ package body Einfo is procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Constant, -- objects - E_Variable) + (Ekind (Id) in E_Constant -- objects + | E_Variable or else - Ekind_In (Id, E_Abstract_State, -- overloadable - E_Entry, - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Operator, - E_Procedure, - E_Subprogram_Body) + Ekind (Id) in E_Abstract_State -- overloadable + | E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Operator + | E_Procedure + | E_Subprogram_Body or else - Ekind_In (Id, E_Generic_Package, -- packages - E_Package, - E_Package_Body) + Ekind (Id) in E_Generic_Package -- packages + | E_Package + | E_Package_Body or else - Ekind (Id) = E_Void -- special purpose + Ekind (Id) = E_Void -- special purpose or else - Ekind_In (Id, E_Protected_Body, -- types - E_Task_Body) + Ekind (Id) in E_Protected_Body -- types + | E_Task_Body or else Is_Type (Id)); Set_Flag265 (Id, V); @@ -6730,9 +6738,9 @@ package body Einfo is procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Constant, - E_Loop_Parameter, - E_Variable)); + pragma Assert (Ekind (Id) in E_Constant + | E_Loop_Parameter + | E_Variable); Set_Node15 (Id, V); end Set_Status_Flag_Or_Transient_Decl; @@ -6827,7 +6835,7 @@ package body Einfo is procedure Set_Thunk_Entity (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + pragma Assert (Ekind (Id) in E_Function | E_Procedure and then Is_Thunk (Id)); Set_Node31 (Id, V); end Set_Thunk_Entity; @@ -6909,7 +6917,7 @@ package body Einfo is procedure Set_Wrapped_Entity (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + pragma Assert (Ekind (Id) in E_Function | E_Procedure and then Is_Primitive_Wrapper (Id)); Set_Node27 (Id, V); end Set_Wrapped_Entity; @@ -7329,7 +7337,7 @@ package body Einfo is end if; loop - if Nkind_In (P, N_Selected_Component, N_Expanded_Name) + if Nkind (P) in N_Selected_Component | N_Expanded_Name or else (Nkind (P) = N_Defining_Program_Unit_Name and then Is_Child_Unit (Id)) then @@ -7445,7 +7453,7 @@ package body Einfo is Comp_Id := First_Entity (Id); while Present (Comp_Id) loop - exit when Ekind_In (Comp_Id, E_Component, E_Discriminant); + exit when Ekind (Comp_Id) in E_Component | E_Discriminant; Next_Entity (Comp_Id); end loop; @@ -7463,9 +7471,9 @@ package body Einfo is pragma Assert (Is_Generic_Subprogram (Id) or else Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind (Id) in E_Entry_Family + | E_Subprogram_Body + | E_Subprogram_Type); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -7504,9 +7512,9 @@ package body Einfo is pragma Assert (Is_Generic_Subprogram (Id) or else Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind (Id) in E_Entry_Family + | E_Subprogram_Body + | E_Subprogram_Type); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -8076,7 +8084,7 @@ package body Einfo is function Is_Constant_Object (Id : E) return B is begin - return Ekind_In (Id, E_Constant, E_In_Parameter, E_Loop_Parameter); + return Ekind (Id) in E_Constant | E_In_Parameter | E_Loop_Parameter; end Is_Constant_Object; ------------------- @@ -8094,7 +8102,7 @@ package body Einfo is function Is_Discriminal (Id : E) return B is begin - return Ekind_In (Id, E_Constant, E_In_Parameter) + return Ekind (Id) in E_Constant | E_In_Parameter and then Present (Discriminal_Link (Id)); end Is_Discriminal; @@ -8156,7 +8164,7 @@ package body Einfo is function Is_Elaboration_Target (Id : Entity_Id) return Boolean is begin return - Ekind_In (Id, E_Constant, E_Package, E_Variable) + Ekind (Id) in E_Constant | E_Package | E_Variable or else Is_Entry (Id) or else Is_Generic_Unit (Id) or else Is_Subprogram (Id) @@ -8204,7 +8212,7 @@ package body Einfo is function Is_Package_Or_Generic_Package (Id : E) return B is begin - return Ekind_In (Id, E_Generic_Package, E_Package); + return Ekind (Id) in E_Generic_Package | E_Package; end Is_Package_Or_Generic_Package; --------------------- @@ -8222,7 +8230,7 @@ package body Einfo is function Is_Prival (Id : E) return B is begin - return Ekind_In (Id, E_Constant, E_Variable) + return Ekind (Id) in E_Constant | E_Variable and then Present (Prival_Link (Id)); end Is_Prival; @@ -8415,9 +8423,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind_In (Id, E_Entry_Family, - E_Subprogram_Body, - E_Subprogram_Type)); + or else Ekind (Id) in E_Entry_Family + | E_Subprogram_Body + | E_Subprogram_Type); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -8588,7 +8596,7 @@ package body Einfo is begin Comp_Id := Next_Entity (Id); while Present (Comp_Id) loop - exit when Ekind_In (Comp_Id, E_Component, E_Discriminant); + exit when Ekind (Comp_Id) in E_Component | E_Discriminant; Next_Entity (Comp_Id); end loop; @@ -8926,9 +8934,9 @@ package body Einfo is then Typ := Full_View (Id); - elsif Ekind_In (Id, E_Array_Subtype, - E_Record_Subtype, - E_Record_Subtype_With_Private) + elsif Ekind (Id) in E_Array_Subtype + | E_Record_Subtype + | E_Record_Subtype_With_Private and then Present (Predicated_Parent (Id)) then Typ := Predicated_Parent (Id); @@ -9842,6 +9850,7 @@ package body Einfo is W ("Is_Atomic", Flag85 (Id)); W ("Is_Bit_Packed_Array", Flag122 (Id)); W ("Is_CPP_Class", Flag74 (Id)); + W ("Is_CUDA_Kernel", Flag118 (Id)); W ("Is_Called", Flag102 (Id)); W ("Is_Character_Type", Flag63 (Id)); W ("Is_Checked_Ghost_Entity", Flag277 (Id)); @@ -11479,7 +11488,7 @@ package body Einfo is begin N := Next_Entity (N); while Present (N) loop - exit when Ekind_In (N, E_Component, E_Discriminant); + exit when Ekind (N) in E_Component | E_Discriminant; N := Next_Entity (N); end loop; end Proc_Next_Component_Or_Discriminant; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index abb7cba..7932c92 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -266,28 +266,29 @@ package Einfo is -- The flag Has_Delayed_Freeze indicates that an entity carries an explicit -- freeze node, which appears later in the expanded tree. --- a) The flag is used by the front-end to trigger expansion actions which +-- a) The flag is used by the front end to trigger expansion activities which -- include the generation of that freeze node. Typically this happens at the -- end of the current compilation unit, or before the first subprogram body is --- encountered in the current unit. See files freeze and exp_ch13 for details +-- encountered in the current unit. See units Freeze and Exp_Ch13 for details -- on the actions triggered by a freeze node, which include the construction -- of initialization procedures and dispatch tables. --- b) The presence of a freeze node on an entity is used by the backend to +-- b) The presence of a freeze node on an entity is used by the back end to -- defer elaboration of the entity until its freeze node is seen. In the -- absence of an explicit freeze node, an entity is frozen (and elaborated) -- at the point of declaration. -- For object declarations, the flag is set when an address clause for the -- object is encountered. Legality checks on the address expression only take --- place at the freeze point of the object. +-- place at the freeze point of the object. In Ada 2012, the flag is also set +-- when an address aspect for the object is encountered. -- Most types have an explicit freeze node, because they cannot be elaborated -- until all representation and operational items that apply to them have been -- analyzed. Private types and incomplete types have the flag set as well, as -- do task and protected types. --- Implicit base types created for type derivations, as well as classwide +-- Implicit base types created for type derivations, as well as class-wide -- types created for all tagged types, have the flag set. -- If a subprogram has an access parameter whose designated type is incomplete @@ -2507,6 +2508,10 @@ package Einfo is -- Defined in all type entities, set only for tagged types to which a -- valid pragma Import (CPP, ...) or pragma CPP_Class has been applied. +-- Is_CUDA_Kernel (Flag118) +-- Defined in function and procedure entities. Set if the subprogram is a +-- CUDA kernel. + -- Is_Decimal_Fixed_Point_Type (synthesized) -- Applies to all type entities, true for decimal fixed point -- types and subtypes. @@ -6238,6 +6243,7 @@ package Einfo is -- Is_Abstract_Subprogram (Flag19) (non-generic case only) -- Is_Called (Flag102) (non-generic case only) -- Is_Constructor (Flag76) + -- Is_CUDA_Kernel (Flag118) (non-generic case only) -- Is_DIC_Procedure (Flag132) (non-generic case only) -- Is_Discrim_SO_Function (Flag176) -- Is_Discriminant_Check_Function (Flag264) @@ -6565,6 +6571,7 @@ package Einfo is -- Is_Asynchronous (Flag81) -- Is_Called (Flag102) (non-generic case only) -- Is_Constructor (Flag76) + -- Is_CUDA_Kernel (Flag118) -- Is_DIC_Procedure (Flag132) (non-generic case only) -- Is_Elaboration_Checks_OK_Id (Flag148) -- Is_Elaboration_Warnings_OK_Id (Flag304) @@ -7344,6 +7351,7 @@ package Einfo is function Is_Controlled_Active (Id : E) return B; function Is_Controlling_Formal (Id : E) return B; function Is_CPP_Class (Id : E) return B; + function Is_CUDA_Kernel (Id : E) return B; function Is_Descendant_Of_Address (Id : E) return B; function Is_DIC_Procedure (Id : E) return B; function Is_Discrim_SO_Function (Id : E) return B; @@ -7623,6 +7631,7 @@ package Einfo is function Is_Integer_Type (Id : E) return B; function Is_Limited_Record (Id : E) return B; function Is_Modular_Integer_Type (Id : E) return B; + function Is_Named_Access_Type (Id : E) return B; function Is_Named_Number (Id : E) return B; function Is_Numeric_Type (Id : E) return B; function Is_Object (Id : E) return B; @@ -8058,6 +8067,7 @@ package Einfo is procedure Set_Is_Controlled_Active (Id : E; V : B := True); procedure Set_Is_Controlling_Formal (Id : E; V : B := True); procedure Set_Is_CPP_Class (Id : E; V : B := True); + procedure Set_Is_CUDA_Kernel (Id : E; V : B := True); procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True); procedure Set_Is_DIC_Procedure (Id : E; V : B := True); procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True); @@ -8902,6 +8912,7 @@ package Einfo is pragma Inline (Is_Controlled_Active); pragma Inline (Is_Controlling_Formal); pragma Inline (Is_CPP_Class); + pragma Inline (Is_CUDA_Kernel); pragma Inline (Is_Decimal_Fixed_Point_Type); pragma Inline (Is_Descendant_Of_Address); pragma Inline (Is_DIC_Procedure); @@ -9504,6 +9515,7 @@ package Einfo is pragma Inline (Set_Is_Controlled_Active); pragma Inline (Set_Is_Controlling_Formal); pragma Inline (Set_Is_CPP_Class); + pragma Inline (Set_Is_CUDA_Kernel); pragma Inline (Set_Is_Descendant_Of_Address); pragma Inline (Set_Is_DIC_Procedure); pragma Inline (Set_Is_Discrim_SO_Function); diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 8c60a3f..1063d7d 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -630,6 +630,24 @@ package body Errout is end if; end Error_Msg_Ada_2012_Feature; + -------------------------------- + -- Error_Msg_Ada_2020_Feature -- + -------------------------------- + + procedure Error_Msg_Ada_2020_Feature (Feature : String; Loc : Source_Ptr) is + begin + if Ada_Version < Ada_2020 then + Error_Msg (Feature & " is an Ada 2020 feature", Loc); + + if No (Ada_Version_Pragma) then + Error_Msg ("\unit must be compiled with -gnat2020 switch", Loc); + else + Error_Msg_Sloc := Sloc (Ada_Version_Pragma); + Error_Msg ("\incompatible with Ada version set#", Loc); + end if; + end if; + end Error_Msg_Ada_2020_Feature; + ------------------ -- Error_Msg_AP -- ------------------ @@ -3293,11 +3311,11 @@ package body Errout is exit when Nkind (P) not in N_Subexpr; end loop; - if Nkind_In (P, N_Pragma_Argument_Association, - N_Component_Association, - N_Discriminant_Association, - N_Generic_Association, - N_Parameter_Association) + if Nkind (P) in N_Pragma_Argument_Association + | N_Component_Association + | N_Discriminant_Association + | N_Generic_Association + | N_Parameter_Association then Set_Error_Posted (Parent (P)); end if; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 1591a37..83a23cc 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -895,12 +895,15 @@ package Errout is -- first formal (RM 9.4(11.9/3)). procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr); - -- If not operating in Ada 2012 mode, posts errors complaining that Feature - -- is only supported in Ada 2012, with appropriate suggestions to fix this. - -- Loc is the location at which the flag is to be posted. Feature, which - -- appears at the start of the first generated message, may contain error - -- message insertion characters in the normal manner, and in particular - -- may start with | to flag a non-serious error. + -- If not operating in Ada 2012 mode or higher, posts errors complaining + -- that Feature is only supported in Ada 2012, with appropriate suggestions + -- to fix this. Loc is the location at which the flag is to be posted. + -- Feature, which appears at the start of the first generated message, may + -- contain error message insertion characters in the normal manner, and in + -- particular may start with | to flag a non-serious error. + + procedure Error_Msg_Ada_2020_Feature (Feature : String; Loc : Source_Ptr); + -- Analogous to Error_Msg_Ada_2012_Feature 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 47a0808..168a592 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -252,7 +252,7 @@ package body Exp_Aggr is function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean; -- Returns true if an aggregate assignment can be done by the back end - function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean; + function Aggr_Size_OK (N : Node_Id) return Boolean; -- Very large static aggregates present problems to the back-end, and are -- transformed into assignments and loops. This function verifies that the -- total number of components of an aggregate is acceptable for rewriting @@ -328,10 +328,10 @@ package body Exp_Aggr is -- is a two dimensional bit packed array with component size 1, 2, or 4. function Max_Aggregate_Size - (Typ : Entity_Id; + (N : Node_Id; Default_Size : Nat := 5000) return Nat; - -- Return the max size for a static aggregate of the given Typ. - -- Return Default_Size if no other special criteria trigger. + -- Return the max size for a static aggregate N. Return Default_Size if no + -- other special criteria trigger. function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; -- Given an array aggregate, this function handles the case of a packed @@ -534,7 +534,7 @@ package body Exp_Aggr is -- Strip away any conversions from the expression as they simply -- qualify the real expression. - while Nkind_In (Expr, N_Unchecked_Type_Conversion, N_Type_Conversion) + while Nkind (Expr) in N_Unchecked_Type_Conversion | N_Type_Conversion loop Expr := Expression (Expr); end loop; @@ -593,7 +593,8 @@ package body Exp_Aggr is -- Aggr_Size_OK -- ------------------ - function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean is + function Aggr_Size_OK (N : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (N); Lo : Node_Id; Hi : Node_Id; Indx : Node_Id; @@ -688,9 +689,9 @@ package body Exp_Aggr is if No (Expressions (N)) and then No (Next (First (Component_Associations (N)))) then - Max_Aggr_Size := Max_Aggregate_Size (Typ); + Max_Aggr_Size := Max_Aggregate_Size (N); else - Max_Aggr_Size := Max_Aggregate_Size (Typ, 500_000); + Max_Aggr_Size := Max_Aggregate_Size (N, 500_000); end if; Size := UI_From_Int (Component_Count (Component_Type (Typ))); @@ -854,8 +855,8 @@ package body Exp_Aggr is Expr : Node_Id := Original_Node (N); begin - while Nkind_In (Expr, N_Type_Conversion, - N_Unchecked_Type_Conversion) + while Nkind (Expr) in + N_Type_Conversion | N_Unchecked_Type_Conversion loop Expr := Original_Node (Expression (Expr)); end loop; @@ -1553,9 +1554,9 @@ package body Exp_Aggr is -- the initialization expression denotes. An unanalyzed function -- call may appear as an identifier or an indexed component. - if Nkind_In (Expr, N_Function_Call, - N_Identifier, - N_Indexed_Component) + if Nkind (Expr) in N_Function_Call + | N_Identifier + | N_Indexed_Component and then not Analyzed (Expr) then Preanalyze_And_Resolve (Expr, Comp_Typ); @@ -1736,7 +1737,7 @@ package body Exp_Aggr is -- default initialized components (otherwise Expr_Q is not present). if Present (Expr_Q) - and then Nkind_In (Expr_Q, N_Aggregate, N_Extension_Aggregate) + and then Nkind (Expr_Q) in N_Aggregate | N_Extension_Aggregate then -- At this stage the Expression may not have been analyzed yet -- because the array aggregate code has not been updated to use @@ -3063,9 +3064,9 @@ package body Exp_Aggr is -- the initialization expression denotes. Unanalyzed function calls -- may appear as identifiers or indexed components. - if Nkind_In (Init_Expr, N_Function_Call, - N_Identifier, - N_Indexed_Component) + if Nkind (Init_Expr) in N_Function_Call + | N_Identifier + | N_Indexed_Component and then not Analyzed (Init_Expr) then Preanalyze_And_Resolve (Init_Expr, Comp_Typ); @@ -3489,8 +3490,8 @@ package body Exp_Aggr is -- qualified). elsif Is_Limited_Type (Etype (Ancestor)) - and then Nkind_In (Unqualify (Ancestor), N_Aggregate, - N_Extension_Aggregate) + and then Nkind (Unqualify (Ancestor)) in + N_Aggregate | N_Extension_Aggregate then Ancestor_Is_Expression := True; @@ -3522,8 +3523,8 @@ package body Exp_Aggr is -- If the ancestor part is an aggregate, force its full -- expansion, which was delayed. - if Nkind_In (Unqualify (Ancestor), N_Aggregate, - N_Extension_Aggregate) + if Nkind (Unqualify (Ancestor)) in + N_Aggregate | N_Extension_Aggregate then Set_Analyzed (Ancestor, False); Set_Analyzed (Expression (Ancestor), False); @@ -4782,7 +4783,7 @@ package body Exp_Aggr is Parent_Node : Node_Id; begin - pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate)); + pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate); pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N)); pragma Assert (Is_Record_Type (Typ)); @@ -4896,7 +4897,7 @@ package body Exp_Aggr is -- The check just above may have replaced the aggregate with a CE - if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + if Nkind (N) in N_Aggregate | N_Extension_Aggregate then Target_Expr := New_Copy_Tree (Lhs); Insert_Actions (Parent_Node, Build_Record_Aggr_Code (N, Typ, Target_Expr)); @@ -4955,7 +4956,7 @@ package body Exp_Aggr is is Typ : constant Entity_Id := Etype (N); Dims : constant Nat := Number_Dimensions (Typ); - Max_Others_Replicate : constant Nat := Max_Aggregate_Size (Typ); + Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N); Static_Components : Boolean := True; @@ -4969,9 +4970,8 @@ package body Exp_Aggr is Dims : Nat; Ix : Node_Id; Ixb : Node_Id) return Boolean; - -- Convert the aggregate into a purely positional form if possible. On - -- entry the bounds of all dimensions are known to be static, and the - -- total number of components is safe enough to expand. + -- Convert the aggregate into a purely positional form if possible after + -- checking that the bounds of all dimensions are known to be static. function Is_Flat (N : Node_Id; Dims : Nat) return Boolean; -- Return True if the aggregate N is flat (which is not trivial in the @@ -5476,11 +5476,7 @@ package body Exp_Aggr is -- compatible with the upper bound of the type, and therefore it is -- worth flattening such aggregates as well. - -- For now the back-end expands these aggregates into individual - -- assignments to the target anyway, but it is conceivable that - -- it will eventually be able to treat such aggregates statically??? - - if Aggr_Size_OK (N, Typ) + if Aggr_Size_OK (N) and then Flatten (N, Dims, First_Index (Typ), First_Index (Base_Type (Typ))) then @@ -5506,14 +5502,7 @@ package body Exp_Aggr is if Nkind (N) = N_Aggregate and then Present (Expressions (N)) then Expr := First (Expressions (N)); while Present (Expr) loop - if Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) - or else - (Is_Entity_Name (Expr) - and then Ekind (Entity (Expr)) = E_Enumeration_Literal) - then - null; - - else + if not Compile_Time_Known_Value (Expr) then Error_Msg_N ("non-static object requires elaboration code??", N); exit; @@ -6200,7 +6189,7 @@ package body Exp_Aggr is if Is_Entity_Name (N) then return True; - elsif Nkind_In (N, N_Explicit_Dereference, N_Selected_Component) + elsif Nkind (N) in N_Explicit_Dereference | N_Selected_Component and then Safe_Left_Hand_Side (Prefix (N)) then return True; @@ -6712,7 +6701,7 @@ package body Exp_Aggr is if Needs_Finalization (Typ) and then Is_Entity_Name (Target) and then Present (Entity (Target)) - and then Ekind_In (Entity (Target), E_Constant, E_Variable) + and then Ekind (Entity (Target)) in E_Constant | E_Variable then Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); end if; @@ -6892,9 +6881,78 @@ package body Exp_Aggr is Aggr_Code : constant List_Id := New_List; Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N); + Comp : Node_Id; Decl : Node_Id; Init_Stat : Node_Id; + procedure Expand_Iterated_Component (Comp : Node_Id); + -- Handle iterated_component_association and iterated_Element + -- association by generating a loop over the specified range, + -- given either by a loop parameter specification or an iterator + -- specification. + + ------------------------------- + -- Expand_Iterated_Component -- + ------------------------------- + + procedure Expand_Iterated_Component (Comp : Node_Id) is + Expr : constant Node_Id := Expression (Comp); + Loop_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Comp))); + + L_Range : Node_Id; + L_Iteration_Scheme : Node_Id; + Loop_Stat : Node_Id; + Stats : List_Id; + + begin + if Present (Iterator_Specification (Comp)) then + L_Iteration_Scheme := + Make_Iteration_Scheme (Loc, + Iterator_Specification => Iterator_Specification (Comp)); + + else + L_Range := Relocate_Node (First (Discrete_Choices (Comp))); + L_Iteration_Scheme := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => L_Range)); + end if; + + -- Build insertion statement. For a positional aggregate, only the + -- expression is needed. For a named aggregate, the loop variable, + -- whose type is that of the key, is an additional parameter for + -- the insertion operation. + + if Present (Add_Unnamed_Subp) then + Stats := New_List + (Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Copy_Tree (Expr)))); + else + Stats := New_List + (Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Entity (Add_Named_Subp), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Occurrence_Of (Loop_Id, Loc), + New_Copy_Tree (Expr)))); + end if; + + Loop_Stat := Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => L_Iteration_Scheme, + Statements => Stats); + Append (Loop_Stat, Aggr_Code); + + end Expand_Iterated_Component; + begin Parse_Aspect_Aggregate (Asp, Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, @@ -6905,7 +6963,7 @@ package body Exp_Aggr is Object_Definition => New_Occurrence_Of (Typ, Loc)); Insert_Action (N, Decl); - if Ekind (Entity (Empty_Subp)) = E_Constant then + if Ekind (Entity (Empty_Subp)) = E_Function then Init_Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Temp, Loc), Expression => Make_Function_Call (Loc, @@ -6915,28 +6973,312 @@ package body Exp_Aggr is Name => New_Occurrence_Of (Temp, Loc), Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc)); end if; + Append (Init_Stat, Aggr_Code); - -- First case: positional aggregate + --------------------------- + -- Positional aggregate -- + --------------------------- - if Present (Expressions (N)) then + if Present (Add_Unnamed_Subp) + and then No (Assign_Indexed_Subp) + then + if Present (Expressions (N)) then + declare + Insert : constant Entity_Id := Entity (Add_Unnamed_Subp); + Comp : Node_Id; + Stat : Node_Id; + + begin + Comp := First (Expressions (N)); + while Present (Comp) loop + Stat := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Insert, Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Copy_Tree (Comp))); + Append (Stat, Aggr_Code); + Next (Comp); + end loop; + end; + end if; + + -- Iterated component associations may also be present. + + Comp := First (Component_Associations (N)); + while Present (Comp) loop + Expand_Iterated_Component (Comp); + Next (Comp); + end loop; + + --------------------- + -- Named_Aggregate -- + --------------------- + + elsif Present (Add_Named_Subp) then declare - Insert : constant Entity_Id := Entity (Add_Unnamed_Subp); - Comp : Node_Id; + Insert : constant Entity_Id := Entity (Add_Named_Subp); Stat : Node_Id; + Key : Node_Id; begin - Comp := First (Expressions (N)); + Comp := First (Component_Associations (N)); + + -- Each component association may contain several choices; + -- generate an insertion statement for each. + while Present (Comp) loop - Stat := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Insert, Loc), - Parameter_Associations => - New_List (New_Occurrence_Of (Temp, Loc), - New_Copy_Tree (Comp))); - Append (Stat, Aggr_Code); + if Nkind (Comp) = N_Iterated_Component_Association then + Expand_Iterated_Component (Comp); + else + Key := First (Choices (Comp)); + + while Present (Key) loop + Stat := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Insert, Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Copy_Tree (Key), + New_Copy_Tree (Expression (Comp)))); + Append (Stat, Aggr_Code); + + Next (Key); + end loop; + end if; + Next (Comp); end loop; end; + + ----------------------- + -- Indexed_Aggregate -- + ----------------------- + + elsif Present (Assign_Indexed_Subp) then + declare + Insert : constant Entity_Id := Entity (Assign_Indexed_Subp); + Index_Type : constant Entity_Id := + Etype (Next_Formal (First_Formal (Insert))); + + function Aggregate_Size return Int; + -- Compute number of entries in aggregate, including choices + -- that cover a range, as well as iterated constructs. + + function Expand_Range_Component + (Rng : Node_Id; + Expr : Node_Id) return Node_Id; + -- Transform a component assoication with a range into an + -- explicit loop. If the choice is a subtype name, it is + -- rewritten as a range with the corresponding bounds, which + -- are known to be static. + + Comp : Node_Id; + Index : Node_Id; + Pos : Int := 0; + Stat : Node_Id; + Key : Node_Id; + Size : Int := 0; + + ----------------------------- + -- Expand_Raange_Component -- + ----------------------------- + + function Expand_Range_Component + (Rng : Node_Id; + Expr : Node_Id) return Node_Id + is + Loop_Id : constant Entity_Id := + Make_Temporary (Loc, 'T'); + + L_Iteration_Scheme : Node_Id; + Stats : List_Id; + + begin + L_Iteration_Scheme := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => New_Copy_Tree (Rng))); + + Stats := New_List + (Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Entity (Assign_Indexed_Subp), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Occurrence_Of (Loop_Id, Loc), + New_Copy_Tree (Expr)))); + + return Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => L_Iteration_Scheme, + Statements => Stats); + end Expand_Range_Component; + + -------------------- + -- Aggregate_Size -- + -------------------- + + function Aggregate_Size return Int is + Comp : Node_Id; + Choice : Node_Id; + Lo, Hi : Node_Id; + Siz : Int := 0; + + procedure Add_Range_Size; + -- Compute size of component association given by + -- range or subtype name. + + procedure Add_Range_Size is + begin + if Nkind (Lo) = N_Integer_Literal then + Siz := Siz + UI_To_Int (Intval (Hi)) + - UI_To_Int (Intval (Lo)) + 1; + end if; + end Add_Range_Size; + + begin + if Present (Expressions (N)) then + Siz := List_Length (Expressions (N)); + end if; + + if Present (Component_Associations (N)) then + Comp := First (Component_Associations (N)); + while Present (Comp) loop + Choice := First (Choices (Comp)); + + while Present (Choice) loop + Analyze (Choice); + + if Nkind (Choice) = N_Range then + Lo := Low_Bound (Choice); + Hi := High_Bound (Choice); + Add_Range_Size; + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Lo := Type_Low_Bound (Entity (Choice)); + Hi := Type_High_Bound (Entity (Choice)); + Add_Range_Size; + Rewrite (Choice, + Make_Range (Loc, + New_Copy_Tree (Lo), + New_Copy_Tree (Hi))); + + else + Resolve (Choice, Index_Type); + Siz := Siz + 1; + end if; + + Next (Choice); + end loop; + Next (Comp); + end loop; + end if; + + return Siz; + end Aggregate_Size; + + begin + Size := Aggregate_Size; + if Size > 0 then + + -- Modify the call to the constructor to allocate the + -- required size for the aggregwte : call the provided + -- constructor rather than the Empty aggregate. + + Index := Make_Op_Add (Loc, + Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)), + Right_Opnd => Make_Integer_Literal (Loc, Size - 1)); + + Set_Expression (Init_Stat, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Entity (New_Indexed_Subp), Loc), + Parameter_Associations => + New_List ( + New_Copy_Tree (Type_Low_Bound (Index_Type)), + Index))); + end if; + + if Present (Expressions (N)) then + Comp := First (Expressions (N)); + + while Present (Comp) loop + + -- Compute index position for successive components + -- in the list of expressions, and use the indexed + -- assignment procedure for each. + + Index := Make_Op_Add (Loc, + Left_Opnd => Type_Low_Bound (Index_Type), + Right_Opnd => Make_Integer_Literal (Loc, Pos)); + + Stat := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Insert, Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + Index, + New_Copy_Tree (Comp))); + + Pos := Pos + 1; + + Append (Stat, Aggr_Code); + Next (Comp); + end loop; + end if; + + if Present (Component_Associations (N)) then + Comp := First (Component_Associations (N)); + + -- The choice may be a static value, or a range with + -- static bounds. + + while Present (Comp) loop + if Nkind (Comp) = N_Component_Association then + Key := First (Choices (Comp)); + while Present (Key) loop + + -- If the expression is a box, the corresponding + -- component (s) is left uninitialized. + + if Box_Present (Comp) then + goto Next_Key; + + elsif Nkind (Key) = N_Range then + + -- Create loop for tne specified range, + -- with copies of the expression. + + Stat := + Expand_Range_Component (Key, Expression (Comp)); + + else + Stat := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of + (Entity (Assign_Indexed_Subp), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Temp, Loc), + New_Copy_Tree (Key), + New_Copy_Tree (Expression (Comp)))); + end if; + + Append (Stat, Aggr_Code); + + <<Next_Key>> + Next (Key); + end loop; + else + Error_Msg_N ("iterated associations peding", N); + end if; + Next (Comp); + end loop; + end if; + end; end if; + Insert_Actions (N, Aggr_Code); Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, Typ); @@ -7757,8 +8099,8 @@ package body Exp_Aggr is begin Aggr := N; while Present (Parent (Aggr)) - and then Nkind_In (Parent (Aggr), N_Aggregate, - N_Component_Association) + and then Nkind (Parent (Aggr)) in + N_Aggregate | N_Component_Association loop Aggr := Parent (Aggr); end loop; @@ -7804,8 +8146,8 @@ package body Exp_Aggr is -- aggregates for C++ imported types must be expanded. elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then - if not Nkind_In (Parent (N), N_Component_Association, - N_Object_Declaration) + if Nkind (Parent (N)) not in + N_Component_Association | N_Object_Declaration then Convert_To_Assignments (N, Typ); @@ -7915,7 +8257,7 @@ package body Exp_Aggr is begin R := Get_Referenced_Object (N); - while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice) + while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice loop R := Get_Referenced_Object (Prefix (R)); end loop; @@ -7937,7 +8279,7 @@ package body Exp_Aggr is Expr : Node_Id; begin - pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate)); + pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate); if No (Comps) then return False; @@ -7965,7 +8307,7 @@ package body Exp_Aggr is Expr := Expression (C); if Present (Expr) - and then Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) + and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate and then Has_Default_Init_Comps (Expr) then return True; @@ -8018,7 +8360,7 @@ package body Exp_Aggr is Kind := Nkind (Node); end if; - if not Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) then + if Kind not in N_Aggregate | N_Extension_Aggregate then return False; else return Expansion_Delayed (Node); @@ -8190,7 +8532,7 @@ package body Exp_Aggr is if Needs_Finalization (Typ) and then Is_Entity_Name (Target) and then Present (Entity (Target)) - and then Ekind_In (Entity (Target), E_Constant, E_Variable) + and then Ekind (Entity (Target)) in E_Constant | E_Variable then Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); end if; @@ -8217,8 +8559,69 @@ package body Exp_Aggr is ------------------------ function Max_Aggregate_Size - (Typ : Entity_Id; - Default_Size : Nat := 5000) return Nat is + (N : Node_Id; + Default_Size : Nat := 5000) return Nat + is + Typ : constant Entity_Id := Etype (N); + + function Use_Small_Size (N : Node_Id) return Boolean; + -- True if we should return a very small size, which means large + -- aggregates will be implemented as a loop when possible (potentially + -- transformed to memset calls). + + function Aggr_Context (N : Node_Id) return Node_Id; + -- Return the context in which the aggregate appears, not counting + -- qualified expressions and similar. + + function Aggr_Context (N : Node_Id) return Node_Id is + Result : Node_Id := Parent (N); + begin + if Nkind (Result) in N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + | N_If_Expression + | N_Case_Expression + | N_Component_Association + | N_Aggregate + then + Result := Aggr_Context (Result); + end if; + + return Result; + end Aggr_Context; + + function Use_Small_Size (N : Node_Id) return Boolean is + C : constant Node_Id := Aggr_Context (N); + -- The decision depends on the context in which the aggregate occurs, + -- and for variable declarations, whether we are nested inside a + -- subprogram. + begin + case Nkind (C) is + -- True for assignment statements and similar + + when N_Assignment_Statement + | N_Simple_Return_Statement + | N_Allocator + | N_Attribute_Reference + => + return True; + + -- True for nested variable declarations. False for library level + -- variables, and for constants (whether or not nested). + + when N_Object_Declaration => + return not Constant_Present (C) + and then Ekind (Current_Scope) in Subprogram_Kind; + + -- False for all other contexts + + when others => + return False; + end case; + end Use_Small_Size; + + -- Start of processing for Max_Aggregate_Size + begin -- We use a small limit in CodePeer mode where we favor loops -- instead of thousands of single assignments (from large aggregates). @@ -8234,10 +8637,6 @@ package body Exp_Aggr is -- if components are static it is much more efficient to construct a -- one-dimensional equivalent array with static components. - -- Finally we also use a small limit when we're within a subprogram - -- since we want to favor loops (potentially transformed to memset - -- calls) in this context. - if CodePeer_Mode then return 100; elsif Restriction_Active (No_Elaboration_Code) @@ -8247,11 +8646,11 @@ package body Exp_Aggr is and then Static_Elaboration_Desired (Current_Scope)) then return 2 ** 24; - elsif Ekind (Current_Scope) in Subprogram_Kind then + elsif Use_Small_Size (N) then return 64; - else - return Default_Size; end if; + + return Default_Size; end Max_Aggregate_Size; ----------------------- @@ -8971,7 +9370,7 @@ package body Exp_Aggr is function Is_Static_Component (Nod : Node_Id) return Boolean is begin - if Nkind_In (Nod, N_Integer_Literal, N_Real_Literal) then + if Nkind (Nod) in N_Integer_Literal | N_Real_Literal then return True; elsif Is_Entity_Name (Nod) @@ -9055,7 +9454,7 @@ package body Exp_Aggr is return False; end if; - if not Aggr_Size_OK (N, Typ) then + if not Aggr_Size_OK (N) then return False; end if; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 14ffe8e..855aa29 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -533,10 +533,7 @@ package body Exp_Attr is -- Comes_From_Source is not correct because this will eliminate the -- components within the corresponding record of a protected type. - if Nam_In (Field_Nam, Name_uObject, - Name_uParent, - Name_uTag) - then + if Field_Nam in Name_uObject | Name_uParent | Name_uTag then null; -- Do not process fields without any scalar components @@ -941,12 +938,35 @@ package body Exp_Attr is is -- The value of the attribute_reference is a record containing two -- fields: an access to the protected object, and an access to the - -- subprogram itself. The prefix is a selected component. + -- subprogram itself. The prefix is an identifier or a selected + -- component. + + function Has_By_Protected_Procedure_Prefixed_View return Boolean; + -- Determine whether Pref denotes the prefixed class-wide interface + -- view of a procedure with synchronization kind By_Protected_Procedure. + + ---------------------------------------------- + -- Has_By_Protected_Procedure_Prefixed_View -- + ---------------------------------------------- + + function Has_By_Protected_Procedure_Prefixed_View return Boolean is + begin + return Nkind (Pref) = N_Selected_Component + and then Nkind (Prefix (Pref)) in N_Has_Entity + and then Present (Entity (Prefix (Pref))) + and then Is_Class_Wide_Type (Etype (Entity (Prefix (Pref)))) + and then (Is_Synchronized_Interface (Etype (Entity (Prefix (Pref)))) + or else + Is_Protected_Interface (Etype (Entity (Prefix (Pref))))) + and then Is_By_Protected_Procedure (Entity (Selector_Name (Pref))); + end Has_By_Protected_Procedure_Prefixed_View; + + -- Local variables Loc : constant Source_Ptr := Sloc (N); Agg : Node_Id; Btyp : constant Entity_Id := Base_Type (Typ); - Sub : Entity_Id; + Sub : Entity_Id := Empty; Sub_Ref : Node_Id; E_T : constant Entity_Id := Equivalent_Type (Btyp); Acc : constant Entity_Id := @@ -1015,6 +1035,23 @@ package body Exp_Attr is Attribute_Name => Name_Address); end if; + elsif Has_By_Protected_Procedure_Prefixed_View then + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (Pref)), + Attribute_Name => Name_Address); + + -- Analyze the object address with expansion disabled. Required + -- because its expansion would displace the pointer to the object, + -- which is not correct at this stage since the object type is a + -- class-wide interface type and we are dispatching a call to a + -- thunk (which would erroneously displace the pointer again). + + Expander_Mode_Save_And_Set (False); + Analyze (Obj_Ref); + Set_Analyzed (Obj_Ref); + Expander_Mode_Restore; + -- Case where the prefix is not an entity name. Find the -- version of the protected operation to be called from -- outside the protected object. @@ -1031,26 +1068,64 @@ package body Exp_Attr is Attribute_Name => Name_Address); end if; - Sub_Ref := - Make_Attribute_Reference (Loc, - Prefix => Sub, - Attribute_Name => Name_Access); + if Has_By_Protected_Procedure_Prefixed_View then + declare + Ctrl_Tag : Node_Id := Duplicate_Subexpr (Prefix (Pref)); + Prim_Addr : Node_Id; + Subp : constant Entity_Id := Entity (Selector_Name (Pref)); + Typ : constant Entity_Id := + Etype (Etype (Entity (Prefix (Pref)))); + begin + -- The target subprogram is a thunk; retrieve its address from + -- its secondary dispatch table slot. + + Build_Get_Prim_Op_Address (Loc, + Typ => Typ, + Tag_Node => Ctrl_Tag, + Position => DT_Position (Subp), + New_Node => Prim_Addr); + + -- Mark the access to the target subprogram as an access to the + -- dispatch table and perform an unchecked type conversion to such + -- access type. This is required to allow the backend to properly + -- identify and handle the access to the dispatch table slot on + -- targets where the dispatch table contains descriptors (instead + -- of pointers). + + Set_Is_Dispatch_Table_Entity (Acc); + Sub_Ref := Unchecked_Convert_To (Acc, Prim_Addr); + Analyze (Sub_Ref); + + Agg := + Make_Aggregate (Loc, + Expressions => New_List (Obj_Ref, Sub_Ref)); + end; - -- We set the type of the access reference to the already generated - -- access_to_subprogram type, and declare the reference analyzed, to - -- prevent further expansion when the enclosing aggregate is analyzed. + -- Common case - Set_Etype (Sub_Ref, Acc); - Set_Analyzed (Sub_Ref); + else + Sub_Ref := + Make_Attribute_Reference (Loc, + Prefix => Sub, + Attribute_Name => Name_Access); + + -- We set the type of the access reference to the already generated + -- access_to_subprogram type, and declare the reference analyzed, + -- to prevent further expansion when the enclosing aggregate is + -- analyzed. - Agg := - Make_Aggregate (Loc, - Expressions => New_List (Obj_Ref, Sub_Ref)); + Set_Etype (Sub_Ref, Acc); + Set_Analyzed (Sub_Ref); - -- Sub_Ref has been marked as analyzed, but we still need to make sure - -- Sub is correctly frozen. + Agg := + Make_Aggregate (Loc, + Expressions => New_List (Obj_Ref, Sub_Ref)); - Freeze_Before (N, Entity (Sub)); + -- Sub_Ref has been marked as analyzed, but we still need to make + -- sure Sub is correctly frozen. + + Freeze_Before (N, Entity (Sub)); + end if; Rewrite (N, Agg); Analyze_And_Resolve (N, E_T); @@ -1952,8 +2027,8 @@ package body Exp_Attr is if Is_Protected_Self_Reference (Pref) and then not - (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint, - N_Discriminant_Association) + (Nkind (Parent (N)) in N_Index_Or_Discriminant_Constraint + | N_Discriminant_Association and then Nkind (Parent (Parent (Parent (Parent (N))))) = N_Component_Definition) @@ -2022,9 +2097,9 @@ package body Exp_Attr is begin Obj_Name := N; - while Nkind_In (Obj_Name, N_Selected_Component, - N_Indexed_Component, - N_Slice) + while Nkind (Obj_Name) in N_Selected_Component + | N_Indexed_Component + | N_Slice loop Obj_Name := Prefix (Obj_Name); end loop; @@ -2192,7 +2267,7 @@ package body Exp_Attr is begin Subp := Current_Scope; - while Ekind_In (Subp, E_Loop, E_Block) loop + while Ekind (Subp) in E_Loop | E_Block loop Subp := Scope (Subp); end loop; @@ -7588,7 +7663,7 @@ package body Exp_Attr is Cnam := Name_Last; end if; - if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration) + if Nkind (P) not in N_Assignment_Statement | N_Object_Declaration or else not Suppress_Assignment_Checks (P) then Insert_Action (N, diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index 02a0652..122a40f 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.adb @@ -268,7 +268,7 @@ package body Exp_CG is return True; elsif not Has_Fully_Qualified_Name (E) then - if Nam_In (Chars (E), Name_uSize, Name_uAlignment, Name_uAssign) + if Chars (E) in Name_uSize | Name_uAlignment | Name_uAssign or else (Chars (E) = Name_Op_Eq and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index acc53b1..abc91a2 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1426,9 +1426,9 @@ package body Exp_Ch11 is -- objects of controlled types, for example. We do not want to clean up -- the return object. - if not Nkind_In (Parent (N), N_Accept_Statement, - N_Extended_Return_Statement, - N_Package_Body) + if Nkind (Parent (N)) not in N_Accept_Statement + | N_Extended_Return_Statement + | N_Package_Body and then not Delay_Cleanups (Current_Scope) and then not Is_Thunk (Current_Scope) then diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 407ffcb..ff1029c 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -160,11 +160,9 @@ package body Exp_Ch2 is and then not (Nkind (Parent (N)) = N_Attribute_Reference and then - (Nam_In (Attribute_Name (Parent (N)), - Name_Asm_Input, - Name_Asm_Output) + (Attribute_Name (Parent (N)) in Name_Asm_Input + | Name_Asm_Output or else Prefix (Parent (N)) = N)) - then -- Case of Current_Value is a compile time known value @@ -406,7 +404,7 @@ package body Exp_Ch2 is -- Set Atomic_Sync_Required if necessary for atomic variable. Note that -- this processing does NOT apply to Volatile_Full_Access variables. - if Nkind_In (N, N_Identifier, N_Expanded_Name) + if Nkind (N) in N_Identifier | N_Expanded_Name and then Ekind (E) = E_Variable and then (Is_Atomic (E) or else Is_Atomic (Etype (E))) then @@ -512,8 +510,8 @@ package body Exp_Ch2 is -- ??? passing a formal as actual for a mode IN formal is -- considered as an assignment? - if Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Entry_Call_Statement) + if Nkind (Parent (N)) in + N_Procedure_Call_Statement | N_Entry_Call_Statement or else (Nkind (Parent (N)) = N_Assignment_Statement and then N = Name (Parent (N))) then @@ -529,9 +527,8 @@ package body Exp_Ch2 is -- which case there is an implicit dereference, and the formal itself -- is not being assigned to). - elsif Nkind_In (Parent (N), N_Selected_Component, - N_Indexed_Component, - N_Slice) + elsif Nkind (Parent (N)) in + N_Selected_Component | N_Indexed_Component | N_Slice and then N = Prefix (Parent (N)) and then not Is_Access_Type (Etype (N)) and then In_Assignment_Context (Parent (N)) @@ -748,7 +745,7 @@ package body Exp_Ch2 is begin -- Simple reference case - if Nkind_In (N, N_Identifier, N_Expanded_Name) then + if Nkind (N) in N_Identifier | N_Expanded_Name then if Is_Formal (Entity (N)) then return Entity (N); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 705da58..0b601c5 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1976,8 +1976,8 @@ package body Exp_Ch3 is -- traversing the expression. ??? if Kind = N_Attribute_Reference - and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access, - Name_Unrestricted_Access) + and then Attribute_Name (Default) in Name_Unchecked_Access + | Name_Unrestricted_Access and then Is_Entity_Name (Prefix (Default)) and then Is_Type (Entity (Prefix (Default))) and then Entity (Prefix (Default)) = Rec_Type @@ -2040,7 +2040,7 @@ package body Exp_Ch3 is end if; if Needs_Finalization (Typ) - and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) + and then Kind not in N_Aggregate | N_Extension_Aggregate and then not Is_Build_In_Place_Function_Call (Exp) then Adj_Call := @@ -3243,10 +3243,10 @@ package body Exp_Ch3 is elsif Ekind (Scope (Id)) = E_Record_Type and then Present (Corresponding_Concurrent_Type (Scope (Id))) - and then Nam_In (Chars (Id), Name_uCPU, - Name_uDispatching_Domain, - Name_uPriority, - Name_uSecondary_Stack_Size) + and then Chars (Id) in Name_uCPU + | Name_uDispatching_Domain + | Name_uPriority + | Name_uSecondary_Stack_Size then declare Exp : Node_Id; @@ -5898,7 +5898,10 @@ package body Exp_Ch3 is Typ := Etype (Comp); if Ekind (Typ) = E_Anonymous_Access_Type - and then Has_Task (Available_View (Designated_Type (Typ))) + and then + (Has_Task (Available_View (Designated_Type (Typ))) + or else + Might_Have_Tasks (Available_View (Designated_Type (Typ)))) and then No (Master_Id (Typ)) then -- Ensure that the record or array type have a _master @@ -6733,9 +6736,9 @@ package body Exp_Ch3 is and then Building_Static_Dispatch_Tables and then Is_Library_Level_Entity (Def_Id) and then Is_Library_Level_Tagged_Type (Base_Typ) - and then Ekind_In (Base_Typ, E_Record_Type, - E_Protected_Type, - E_Task_Type) + and then Ekind (Base_Typ) in E_Record_Type + | E_Protected_Type + | E_Task_Type and then not Has_Dispatch_Table (Base_Typ) then declare @@ -6786,7 +6789,7 @@ package body Exp_Ch3 is and then not Restriction_Active (No_Secondary_Stack) and then (Restriction_Active (No_Implicit_Heap_Allocations) or else Restriction_Active (No_Implicit_Task_Allocations)) - and then not (Ekind_In (Ekind (Typ), E_Array_Type, E_Array_Subtype) + and then not (Ekind (Typ) in E_Array_Type | E_Array_Subtype and then (Has_Init_Expression (N))) then declare @@ -7594,9 +7597,9 @@ package body Exp_Ch3 is -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3 - if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) - and then Nkind (Parent (Parent (N))) /= N_Full_Type_Declaration - and then Nkind (Parent (Parent (N))) /= N_Object_Declaration + if Nkind (Parent (N)) in N_Constrained_Array_Definition | N_Slice + and then Nkind (Parent (Parent (N))) not in + N_Full_Type_Declaration | N_Object_Declaration then Apply_Range_Check (Ran, Typ); end if; @@ -8029,7 +8032,7 @@ package body Exp_Ch3 is -- See GNAT Pool packages in the Run-Time for more details - elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then + elsif Ekind (Def_Id) in E_Access_Type | E_General_Access_Type then declare Loc : constant Source_Ptr := Sloc (N); Desig_Type : constant Entity_Id := Designated_Type (Def_Id); @@ -8148,61 +8151,44 @@ package body Exp_Ch3 is elsif Ada_Version >= Ada_2012 and then Present (Associated_Storage_Pool (Def_Id)) - - -- Omit this check for the case of a configurable run-time that - -- does not provide package System.Storage_Pools.Subpools. - - and then RTE_Available (RE_Root_Storage_Pool_With_Subpools) + and then RTU_Loaded (System_Storage_Pools_Subpools) then declare Loc : constant Source_Ptr := Sloc (Def_Id); Pool : constant Entity_Id := Associated_Storage_Pool (Def_Id); - RSPWS : constant Entity_Id := - RTE (RE_Root_Storage_Pool_With_Subpools); begin -- It is known that the accessibility level of the access -- type is deeper than that of the pool. if Type_Access_Level (Def_Id) > Object_Access_Level (Pool) + and then Is_Class_Wide_Type (Etype (Pool)) and then not Accessibility_Checks_Suppressed (Def_Id) and then not Accessibility_Checks_Suppressed (Pool) then - -- Static case: the pool is known to be a descendant of - -- Root_Storage_Pool_With_Subpools. - - if Is_Ancestor (RSPWS, Etype (Pool)) then - Error_Msg_N - ("??subpool access type has deeper accessibility " - & "level than pool", Def_Id); - - Append_Freeze_Action (Def_Id, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - - -- Dynamic case: when the pool is of a class-wide type, - -- it may or may not support subpools depending on the - -- path of derivation. Generate: + -- When the pool is of a class-wide type, it may or may + -- not support subpools depending on the path of + -- derivation. Generate: -- if Def_Id in RSPWS'Class then -- raise Program_Error; -- end if; - elsif Is_Class_Wide_Type (Etype (Pool)) then - Append_Freeze_Action (Def_Id, - Make_If_Statement (Loc, - Condition => - Make_In (Loc, - Left_Opnd => New_Occurrence_Of (Pool, Loc), - Right_Opnd => - New_Occurrence_Of - (Class_Wide_Type (RSPWS), Loc)), - - Then_Statements => New_List ( - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)))); - end if; + Append_Freeze_Action (Def_Id, + Make_If_Statement (Loc, + Condition => + Make_In (Loc, + Left_Opnd => New_Occurrence_Of (Pool, Loc), + Right_Opnd => + New_Occurrence_Of + (Class_Wide_Type + (RTE + (RE_Root_Storage_Pool_With_Subpools)), + Loc)), + Then_Statements => New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)))); end if; end; end if; @@ -8712,7 +8698,7 @@ package body Exp_Ch3 is -- If the initial value is null or an aggregate, qualify it with the -- underlying type in order to provide a proper context. - if Nkind_In (Expr, N_Aggregate, N_Null) then + if Nkind (Expr) in N_Aggregate | N_Null then Expr := Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (Under_Typ, Loc), diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index dbf3e3b..30824c6 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4149,7 +4149,7 @@ package body Exp_Ch4 is -- we avoid never-ending loops expanding them, and we also ensure -- the back end never receives nonbinary modular type expressions. - if Nkind_In (Nkind (N), N_Op_And, N_Op_Or, N_Op_Xor) then + if Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor then Set_Left_Opnd (Op_Expr, Unchecked_Convert_To (Standard_Unsigned, New_Copy_Tree (Left_Opnd (N)))); @@ -4532,11 +4532,11 @@ package body Exp_Ch4 is -- lifetime of the object must be associated with the named access -- type. Use the finalization-related attributes of this type. - if Nkind_In (Parent (N), N_Type_Conversion, - N_Unchecked_Type_Conversion) - and then Ekind_In (Etype (Parent (N)), E_Access_Subtype, - E_Access_Type, - E_General_Access_Type) + if Nkind (Parent (N)) in N_Type_Conversion + | N_Unchecked_Type_Conversion + and then Ekind (Etype (Parent (N))) in E_Access_Subtype + | E_Access_Type + | E_General_Access_Type then Rel_Typ := Etype (Parent (N)); else @@ -5084,8 +5084,8 @@ package body Exp_Ch4 is New_Occurrence_Of (Entity (Nam), Sloc (Nam)), T); - elsif Nkind_In (Nam, N_Indexed_Component, - N_Selected_Component) + elsif Nkind (Nam) in N_Indexed_Component + | N_Selected_Component and then Is_Entity_Name (Prefix (Nam)) then Decls := @@ -5355,7 +5355,7 @@ package body Exp_Ch4 is -- to which it applies has a static predicate aspect, do not expand, -- because it will be converted to the proper predicate form later. - if Ekind_In (Current_Scope, E_Function, E_Procedure) + if Ekind (Current_Scope) in E_Function | E_Procedure and then Is_Predicate_Function (Current_Scope) then In_Predicate := True; @@ -6224,8 +6224,8 @@ package body Exp_Ch4 is -- to consider??? loop - if Nkind_In (Obj_Ref, N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind (Obj_Ref) in + N_Type_Conversion | N_Unchecked_Type_Conversion then Obj_Ref := Expression (Obj_Ref); else @@ -7081,9 +7081,9 @@ package body Exp_Ch4 is return; elsif Nkind (Parnt) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Parnt), Name_Address, - Name_Bit, - Name_Size) + and then Attribute_Name (Parnt) in Name_Address + | Name_Bit + | Name_Size and then Prefix (Parnt) = Child then return; @@ -8440,13 +8440,12 @@ package body Exp_Ch4 is -- records because there may be padding or undefined fields. elsif Unnest_Subprogram_Mode - and then Ekind_In (Typl, E_Class_Wide_Type, - E_Class_Wide_Subtype, - E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Access_Subprogram_Type, - E_Exception_Type) + and then Ekind (Typl) in E_Class_Wide_Type + | E_Class_Wide_Subtype + | E_Access_Subprogram_Type + | E_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type + | E_Exception_Type and then Present (Equivalent_Type (Typl)) and then Is_Record_Type (Equivalent_Type (Typl)) then @@ -8759,7 +8758,7 @@ package body Exp_Ch4 is -- too tricky to combine the overflow check at the parent level. if not Ovflo - and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) + and then Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply then declare P : constant Node_Id := Parent (N); @@ -9792,13 +9791,12 @@ package body Exp_Ch4 is if Is_Elementary_Type (Typ) and then Sloc (Entity (N)) = Standard_Location - and then not (Ekind_In (Typ, E_Class_Wide_Type, - E_Class_Wide_Subtype, - E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Access_Subprogram_Type, - E_Exception_Type) + and then not (Ekind (Typ) in E_Class_Wide_Type + | E_Class_Wide_Subtype + | E_Access_Subprogram_Type + | E_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type + | E_Exception_Type and then Present (Equivalent_Type (Typ)) and then Is_Record_Type (Equivalent_Type (Typ))) then @@ -9978,7 +9976,7 @@ package body Exp_Ch4 is -- Special case the negation of a binary operation - elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor) + elsif Nkind (Opnd) in N_Op_And | N_Op_Or | N_Op_Xor and then Safe_In_Place_Array_Op (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd)) then @@ -11153,9 +11151,9 @@ package body Exp_Ch4 is -- since these are additional cases that do can appear on -- procedure actuals. - elsif Nkind_In (Par, N_Type_Conversion, - N_Parameter_Association, - N_Qualified_Expression) + elsif Nkind (Par) in N_Type_Conversion + | N_Parameter_Association + | N_Qualified_Expression then Par := Parent (Par); @@ -11305,6 +11303,11 @@ package body Exp_Ch4 is -- True iff Present (Effective_Extra_Accessibility (Id)) successfully -- evaluates to True. + function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id) + return Boolean; + -- Given a target type for a conversion, determine whether the + -- statically deeper accessibility rules apply to it. + -------------------------- -- Discrete_Range_Check -- -------------------------- @@ -11431,7 +11434,7 @@ package body Exp_Ch4 is begin -- Nothing else to do if no change of representation - if Same_Representation (Operand_Type, Target_Type) then + if Has_Compatible_Representation (Target_Type, Operand_Type) then return; -- The real change of representation work is done by the assignment @@ -11880,13 +11883,32 @@ package body Exp_Ch4 is function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is begin - if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then + if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then return Present (Effective_Extra_Accessibility (Id)); else return False; end if; end Has_Extra_Accessibility; + ---------------------------------------- + -- Statically_Deeper_Relation_Applies -- + ---------------------------------------- + + function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id) + return Boolean + is + begin + -- The case where the target type is an anonymous access type is + -- ignored since they have different semantics and get covered by + -- various runtime checks depending on context. + + -- Note, the current implementation of this predicate is incomplete + -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and + -- (19.1) ??? + + return Ekind (Targ_Typ) /= E_Anonymous_Access_Type; + end Statically_Deeper_Relation_Applies; + -- Start of processing for Expand_N_Type_Conversion begin @@ -11951,6 +11973,39 @@ package body Exp_Ch4 is Remove_Side_Effects (N); Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N))); goto Done; + + -- AI12-0042: For a view conversion to a class-wide type occurring + -- within the immediate scope of T, from a specific type that is + -- a descendant of T (including T itself), an invariant check is + -- performed on the part of the object that is of type T. (We don't + -- need to explicitly check for the operand type being a descendant, + -- just that it's a specific type, because the conversion would be + -- illegal if it's specific and not a descendant -- downward conversion + -- is not allowed). + + elsif Is_Class_Wide_Type (Target_Type) + and then not Is_Class_Wide_Type (Etype (Expression (N))) + and then Present (Invariant_Procedure (Root_Type (Target_Type))) + and then Comes_From_Source (N) + and then Within_Scope (Find_Enclosing_Scope (N), Scope (Target_Type)) + then + Remove_Side_Effects (N); + + -- Perform the invariant check on a conversion to the class-wide + -- type's root type. + + declare + Root_Conv : constant Node_Id := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Root_Type (Target_Type), Loc), + Expression => Duplicate_Subexpr (Expression (N))); + begin + Set_Etype (Root_Conv, Root_Type (Target_Type)); + + Insert_Action (N, Make_Invariant_Call (Root_Conv)); + goto Done; + end; end if; -- Here if we may need to expand conversion @@ -12078,9 +12133,9 @@ package body Exp_Ch4 is or else Attribute_Name (Original_Node (N)) = Name_Access) then if not Comes_From_Source (N) - and then Nkind_In (Parent (N), N_Function_Call, - N_Parameter_Association, - N_Procedure_Call_Statement) + and then Nkind (Parent (N)) in N_Function_Call + | N_Parameter_Association + | N_Procedure_Call_Statement and then Is_Interface (Designated_Type (Target_Type)) and then Is_Class_Wide_Type (Designated_Type (Target_Type)) then @@ -12100,21 +12155,7 @@ package body Exp_Ch4 is -- Note: warnings are issued by the analyzer for the instance cases elsif In_Instance_Body - - -- The case where the target type is an anonymous access type of - -- a discriminant is excluded, because the level of such a type - -- depends on the context and currently the level returned for such - -- types is zero, resulting in warnings about check failures - -- in certain legal cases involving class-wide interfaces as the - -- designated type (some cases, such as return statements, are - -- checked at run time, but not clear if these are handled right - -- in general, see 3.10.2(12/2-12.5/3) ???). - - and then - not (Ekind (Target_Type) = E_Anonymous_Access_Type - and then Present (Associated_Node_For_Itype (Target_Type)) - and then Nkind (Associated_Node_For_Itype (Target_Type)) = - N_Discriminant_Specification) + and then Statically_Deeper_Relation_Applies (Target_Type) and then Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) then @@ -12411,7 +12452,7 @@ package body Exp_Ch4 is -- Special processing is required if there is a change of -- representation (from enumeration representation clauses). - if not Same_Representation (Target_Type, Operand_Type) + if not Has_Compatible_Representation (Target_Type, Operand_Type) and then not Conversion_OK (N) then @@ -12709,7 +12750,7 @@ package body Exp_Ch4 is exit when No (Comp); - exit when Ekind_In (Comp, E_Discriminant, E_Component) + exit when Ekind (Comp) in E_Discriminant | E_Component and then not ( -- Skip inherited components @@ -13487,13 +13528,9 @@ package body Exp_Ch4 is -- value and unary negation. Unary "+" is omitted since it is a -- no-op and thus can't overflow. - and then Nkind_In (Operand, N_Op_Abs, - N_Op_Add, - N_Op_Divide, - N_Op_Expon, - N_Op_Minus, - N_Op_Multiply, - N_Op_Subtract); + and then Nkind (Operand) in + N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon | + N_Op_Minus | N_Op_Multiply | N_Op_Subtract; end Integer_Promotion_Possible; ------------------------------ @@ -14703,9 +14740,9 @@ package body Exp_Ch4 is -- transient object. begin - pragma Assert (Nkind_In (Expr, N_Case_Expression, - N_Expression_With_Actions, - N_If_Expression)); + pragma Assert (Nkind (Expr) in N_Case_Expression + | N_Expression_With_Actions + | N_If_Expression); -- When the context is a Boolean evaluation, all three nodes capture the -- result of their computation in a local temporary: @@ -14772,7 +14809,7 @@ package body Exp_Ch4 is -- <or> -- Hook := Obj_Id'Unrestricted_Access; - if Ekind_In (Obj_Id, E_Constant, E_Variable) + if Ekind (Obj_Id) in E_Constant | E_Variable and then Present (Last_Aggregate_Assignment (Obj_Id)) then Hook_Insert := Last_Aggregate_Assignment (Obj_Id); @@ -14906,7 +14943,7 @@ package body Exp_Ch4 is elsif Is_Entity_Name (Op) then return Is_Unaliased (Op); - elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then + elsif Nkind (Op) in N_Indexed_Component | N_Selected_Component then return Is_Unaliased (Prefix (Op)); elsif Nkind (Op) = N_Slice then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index e98fcf7..309297b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -278,8 +278,9 @@ package body Exp_Ch5 is begin return Nkind (Rhs) = N_Type_Conversion - and then - not Same_Representation (Etype (Rhs), Etype (Expression (Rhs))); + and then not Has_Compatible_Representation + (Target_Type => Etype (Rhs), + Operand_Type => Etype (Expression (Rhs))); end Change_Of_Representation; ------------------------------ @@ -1451,17 +1452,14 @@ package body Exp_Ch5 is L_Prefix_Comp : constant Boolean := -- True if the left-hand side is a slice of a component or slice Nkind (Name (N)) = N_Slice - and then Nkind_In (Prefix (Name (N)), - N_Selected_Component, - N_Indexed_Component, - N_Slice); + and then Nkind (Prefix (Name (N))) in + N_Selected_Component | N_Indexed_Component | N_Slice; R_Prefix_Comp : constant Boolean := -- Likewise for the right-hand side Nkind (Expression (N)) = N_Slice - and then Nkind_In (Prefix (Expression (N)), - N_Selected_Component, - N_Indexed_Component, - N_Slice); + and then Nkind (Prefix (Expression (N))) in + N_Selected_Component | N_Indexed_Component | N_Slice; + begin -- Determine whether Copy_Bitfield is appropriate (will work, and will -- be more efficient than component-by-component copy). Copy_Bitfield @@ -1521,7 +1519,7 @@ package body Exp_Ch5 is -- be assigned. elsif Possible_Bit_Aligned_Component (Lhs) - or + or else Possible_Bit_Aligned_Component (Rhs) then null; @@ -1898,8 +1896,8 @@ package body Exp_Ch5 is -- We know the underlying type is a record, but its current view -- may be private. We must retrieve the usable record declaration. - if Nkind_In (Decl, N_Private_Type_Declaration, - N_Private_Extension_Declaration) + if Nkind (Decl) in N_Private_Type_Declaration + | N_Private_Extension_Declaration and then Present (Full_View (R_Typ)) then RDef := Type_Definition (Declaration_Node (Full_View (R_Typ))); @@ -2259,7 +2257,7 @@ package body Exp_Ch5 is -- Since P is going to be evaluated more than once, any subscripts -- in P must have their evaluation forced. - if Nkind_In (Lhs, N_Indexed_Component, N_Selected_Component) + if Nkind (Lhs) in N_Indexed_Component | N_Selected_Component and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs)) then declare @@ -2295,8 +2293,7 @@ package body Exp_Ch5 is loop Set_Analyzed (Exp, False); - if Nkind_In (Exp, N_Indexed_Component, - N_Selected_Component) + if Nkind (Exp) in N_Indexed_Component | N_Selected_Component then Exp := Prefix (Exp); else @@ -2864,8 +2861,8 @@ package body Exp_Ch5 is Actual_Rhs : Node_Id := Rhs; begin - while Nkind_In (Actual_Rhs, N_Type_Conversion, - N_Qualified_Expression) + while Nkind (Actual_Rhs) in + N_Type_Conversion | N_Qualified_Expression loop Actual_Rhs := Expression (Actual_Rhs); end loop; @@ -2939,7 +2936,7 @@ package body Exp_Ch5 is -- Skip this if left-hand side is an array or record component -- and elementary component validity checks are suppressed. - if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component) + if Nkind (Lhs) in N_Selected_Component | N_Indexed_Component and then not Validity_Check_Components then null; @@ -3790,9 +3787,9 @@ package body Exp_Ch5 is Else_Expr : constant Node_Id := Expression (Else_Stm); begin - if Nkind_In (Then_Expr, N_Expanded_Name, N_Identifier) + if Nkind (Then_Expr) in N_Expanded_Name | N_Identifier and then - Nkind_In (Else_Expr, N_Expanded_Name, N_Identifier) + Nkind (Else_Expr) in N_Expanded_Name | N_Identifier then if Entity (Then_Expr) = Standard_True and then Entity (Else_Expr) = Standard_False diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index a42bd25..57d3884 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -661,8 +661,8 @@ package body Exp_Ch6 is and then not Scope_Suppress.Suppress (Accessibility_Check) and then (Is_Class_Wide_Type (Etype (Exp)) - or else Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) + or else Nkind (Exp) in + N_Type_Conversion | N_Unchecked_Type_Conversion or else (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp))) or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > @@ -1070,9 +1070,9 @@ package body Exp_Ch6 is Actual : Node_Id; begin - pragma Assert (Nkind_In (Subp_Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement)); + pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement); Formal := First_Formal_With_Extras (Subp_Id); Actual := First_Actual (Subp_Call); @@ -1106,9 +1106,9 @@ package body Exp_Ch6 is Actual : Node_Id; begin - pragma Assert (Nkind_In (Subp_Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement)); + pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement); Formal := First_Formal_With_Extras (Subp_Id); Actual := First_Actual (Subp_Call); @@ -1571,8 +1571,9 @@ package body Exp_Ch6 is Var := Make_Var (Expression (Actual)); - Crep := not Same_Representation - (F_Typ, Etype (Expression (Actual))); + Crep := not Has_Compatible_Representation + (Target_Type => F_Typ, + Operand_Type => Etype (Expression (Actual))); else V_Typ := Etype (Actual); @@ -2179,7 +2180,7 @@ package body Exp_Ch6 is loop Set_Analyzed (Pfx, False); exit when - not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component); + Nkind (Pfx) not in N_Selected_Component | N_Indexed_Component; Pfx := Prefix (Pfx); end loop; end Reset_Packed_Prefix; @@ -2196,6 +2197,13 @@ package body Exp_Ch6 is return False; end if; + -- There is no requirement inside initialization procedures and this + -- would generate copies for atomic or volatile composite components. + + if Inside_Init_Proc then + return False; + end if; + -- Check for atomicity mismatch if Is_Atomic_Object (Actual) and then not Is_Atomic (E_Formal) @@ -2366,9 +2374,9 @@ package body Exp_Ch6 is -- Also pass by copy if change of representation - or else not Same_Representation - (Etype (Formal), - Etype (Expression (Actual)))) + or else not Has_Compatible_Representation + (Target_Type => Etype (Formal), + Operand_Type => Etype (Expression (Actual)))) then Add_Call_By_Copy_Code; @@ -2595,8 +2603,8 @@ package body Exp_Ch6 is -- root type. elsif - Nkind_In (Parent (Subp), N_Private_Extension_Declaration, - N_Full_Type_Declaration) + Nkind (Parent (Subp)) in N_Private_Extension_Declaration + | N_Full_Type_Declaration then Subp_Decl := Parent (Subp); @@ -2670,9 +2678,9 @@ package body Exp_Ch6 is (Access_Subprogram_Wrapper (Etype (Name (N)))); begin - pragma Assert (Nkind_In (N, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement)); + pragma Assert (Nkind (N) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement); -- Check that this is not the call in the body of the wrapper. @@ -3256,7 +3264,7 @@ package body Exp_Ch6 is Param_Count : Natural := 0; Parent_Formal : Entity_Id; Parent_Subp : Entity_Id; - Pref_Entity : Entity_Id; + Prev_Ult : Node_Id; Scop : Entity_Id; Subp : Entity_Id; @@ -3279,7 +3287,7 @@ package body Exp_Ch6 is if Ada_Version >= Ada_2012 and then - Nkind_In (Call_Node, N_Procedure_Call_Statement, N_Function_Call) + Nkind (Call_Node) in N_Procedure_Call_Statement | N_Function_Call and then Present (Parameter_Associations (Call_Node)) then Expand_Put_Call_With_Symbol (Call_Node); @@ -3579,8 +3587,8 @@ package body Exp_Ch6 is -- as out parameter actuals on calls to stream procedures. Act_Prev := Prev; - while Nkind_In (Act_Prev, N_Type_Conversion, - N_Unchecked_Type_Conversion) + while Nkind (Act_Prev) in N_Type_Conversion + | N_Unchecked_Type_Conversion loop Act_Prev := Expression (Act_Prev); end loop; @@ -3662,9 +3670,7 @@ package body Exp_Ch6 is -- constant declaration defines the accessibility level of X'Old". elsif Nkind (Prev_Orig) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Prev_Orig), - Name_Old, - Name_Loop_Entry) + and then Attribute_Name (Prev_Orig) in Name_Old | Name_Loop_Entry and then Is_Entity_Name (Prev) and then Present (Entity (Prev)) and then Is_Object (Entity (Prev)) @@ -3818,60 +3824,30 @@ package body Exp_Ch6 is Expression (Original_Node (Prev_Orig)); end if; - -- If this is an Access attribute applied to the - -- the current instance object passed to a type - -- initialization procedure, then use the level - -- of the type itself. This is not really correct, - -- as there should be an extra level parameter - -- passed in with _init formals (only in the case - -- where the type is immutably limited), but we - -- don't have an easy way currently to create such - -- an extra formal (init procs aren't ever frozen). - -- For now we just use the level of the type, - -- which may be too shallow, but that works better - -- than passing Object_Access_Level of the type, - -- which can be one level too deep in some cases. - -- ??? - - -- A further case that requires special handling - -- is the common idiom E.all'access. If E is a - -- formal of the enclosing subprogram, the - -- accessibility of the expression is that of E. - - if Is_Entity_Name (Prev_Orig) then - Pref_Entity := Entity (Prev_Orig); - - elsif Nkind (Prev_Orig) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Prev_Orig)) - then - Pref_Entity := Entity (Prefix ((Prev_Orig))); + -- Obtain the ultimate prefix so we can check for + -- the case where we are taking 'Access of a + -- component of an anonymous access formal - which + -- would mean we need to pass said formal's + -- corresponding extra accessibility formal. - else - Pref_Entity := Empty; - end if; + Prev_Ult := Ultimate_Prefix (Prev_Orig); - if Is_Entity_Name (Prev_Orig) - and then Is_Type (Entity (Prev_Orig)) - then - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => - Type_Access_Level (Pref_Entity)), - EF => Get_Accessibility (Formal)); - - elsif Nkind (Prev_Orig) = N_Explicit_Dereference - and then Present (Pref_Entity) - and then Is_Formal (Pref_Entity) + if Is_Entity_Name (Prev_Ult) + and then not Is_Type (Entity (Prev_Ult)) and then Present - (Get_Accessibility (Pref_Entity)) + (Get_Accessibility + (Entity (Prev_Ult))) then Add_Extra_Actual (Expr => New_Occurrence_Of - (Get_Accessibility (Pref_Entity), Loc), + (Get_Accessibility + (Entity (Prev_Ult)), Loc), EF => Get_Accessibility (Formal)); + -- Normal case, call Object_Access_Level. Note: + -- should be Dynamic_Accessibility_Level ??? + else Add_Extra_Actual (Expr => @@ -3927,9 +3903,8 @@ package body Exp_Ch6 is when others => if Nkind (Prev) = N_Expression_With_Actions - and then Nkind_In (Original_Node (Prev), - N_If_Expression, - N_Case_Expression) + and then Nkind (Original_Node (Prev)) in + N_If_Expression | N_Case_Expression then declare Decl : Node_Id; @@ -3970,10 +3945,9 @@ package body Exp_Ch6 is if Nkind (Expression (Assn)) = N_Expression_With_Actions and then - Nkind_In - (Original_Node (Expression (Assn)), - N_Case_Expression, - N_If_Expression) + Nkind + (Original_Node (Expression (Assn))) in + N_Case_Expression | N_If_Expression then Insert_Level_Assign (Expression (Assn)); @@ -4006,8 +3980,8 @@ package body Exp_Ch6 is Cond := First (Actions (Branch)); loop - exit when Nkind_In (Cond, N_Case_Statement, - N_If_Statement); + exit when Nkind (Cond) in + N_Case_Statement | N_If_Statement; Next (Cond); @@ -4191,7 +4165,7 @@ package body Exp_Ch6 is then null; - elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then + elsif Nkind (Prev) in N_Allocator | N_Attribute_Reference then null; else @@ -4223,8 +4197,8 @@ package body Exp_Ch6 is begin Nod := Actual; - while Nkind_In (Nod, N_Indexed_Component, - N_Selected_Component) + while Nkind (Nod) in + N_Indexed_Component | N_Selected_Component loop Set_Analyzed (Nod, False); Nod := Prefix (Nod); @@ -4363,7 +4337,7 @@ package body Exp_Ch6 is -- "accessibility level determined by the point of call" (AI05-0234) -- passed in to it, then pass it in. - if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type) + if Ekind (Subp) in E_Function | E_Operator | E_Subprogram_Type and then Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) then @@ -4658,7 +4632,7 @@ package body Exp_Ch6 is -- and reanalyzed (see Expand_Protected_Subprogram_Call). elsif Is_Protected_Type (Scope (Subp)) - and then Ekind_In (Subp, E_Procedure, E_Function) + and then Ekind (Subp) in E_Procedure | E_Function then null; @@ -4794,7 +4768,10 @@ package body Exp_Ch6 is -- If there is a change of representation, then generate a -- warning, and do the change of representation. - elsif not Same_Representation (Formal_Typ, Parent_Typ) then + elsif not Has_Compatible_Representation + (Target_Type => Formal_Typ, + Operand_Type => Parent_Typ) + then Error_Msg_N ("??change of representation required", Actual); Convert (Actual, Parent_Typ); @@ -4933,7 +4910,7 @@ package body Exp_Ch6 is return; end if; - if Ekind_In (Subp, E_Function, E_Procedure) then + if Ekind (Subp) in E_Function | E_Procedure then -- We perform a simple optimization on calls for To_Address by -- replacing them with an unchecked conversion. Not only is this @@ -5150,14 +5127,14 @@ package body Exp_Ch6 is -- intermediate result after its use. elsif Is_Build_In_Place_Function_Call (Call_Node) - and then Nkind_In (Parent (Unqual_Conv (Call_Node)), - N_Attribute_Reference, - N_Function_Call, - N_Indexed_Component, - N_Object_Renaming_Declaration, - N_Procedure_Call_Statement, - N_Selected_Component, - N_Slice) + and then Nkind (Parent (Unqual_Conv (Call_Node))) in + N_Attribute_Reference + | N_Function_Call + | N_Indexed_Component + | N_Object_Renaming_Declaration + | N_Procedure_Call_Statement + | N_Selected_Component + | N_Slice and then (Ekind (Current_Scope) /= E_Loop or else Nkind (Parent (Call_Node)) /= N_Function_Call @@ -6726,7 +6703,7 @@ package body Exp_Ch6 is -- For a procedure, we add a return for all possible syntactic ends of -- the subprogram. - if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then + if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure then Add_Return (Spec_Id, Statements (HSS)); if Present (Exception_Handlers (HSS)) then @@ -6958,7 +6935,7 @@ package body Exp_Ch6 is -- Call the _Postconditions procedure if the related subprogram has -- contract assertions that need to be verified on exit. - if Ekind_In (Scope_Id, E_Entry, E_Entry_Family, E_Procedure) + if Ekind (Scope_Id) in E_Entry | E_Entry_Family | E_Procedure and then Present (Postconditions_Proc (Scope_Id)) then Insert_Action (N, @@ -7708,8 +7685,8 @@ package body Exp_Ch6 is if Present (Utyp) and then Is_Tagged_Type (Utyp) and then not Is_Class_Wide_Type (Utyp) - and then (Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) + and then (Nkind (Exp) in + N_Type_Conversion | N_Unchecked_Type_Conversion or else (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp)))) then @@ -7860,8 +7837,8 @@ package body Exp_Ch6 is end if; elsif Nkind (Discrim_Source) = N_Identifier - and then Nkind_In (Original_Node (Discrim_Source), - N_Aggregate, N_Extension_Aggregate) + and then Nkind (Original_Node (Discrim_Source)) in + N_Aggregate | N_Extension_Aggregate then Discrim_Source := Original_Node (Discrim_Source); @@ -8343,9 +8320,9 @@ package body Exp_Ch6 is -- in an expression context. if not Is_List_Member (N) - or else Nkind_In (Context, N_Function_Call, - N_If_Expression, - N_Indexed_Component) + or else Nkind (Context) in N_Function_Call + | N_If_Expression + | N_Indexed_Component then -- In Ada 2012 the call may be a function call in an expression -- (since OUT and IN OUT parameters are now allowed for such calls). @@ -8423,8 +8400,8 @@ package body Exp_Ch6 is -- corresponding statement list. else - pragma Assert (Nkind_In (Context, N_Entry_Call_Alternative, - N_Triggering_Alternative)); + pragma Assert (Nkind (Context) in N_Entry_Call_Alternative + | N_Triggering_Alternative); if Is_Non_Empty_List (Statements (Context)) then Insert_List_Before_And_Analyze @@ -8580,7 +8557,7 @@ package body Exp_Ch6 is -- type whose result subtype is inherently limited. Later this test -- may be revised to allow composite nonlimited types. - if Ekind_In (E, E_Function, E_Generic_Function) + if Ekind (E) in E_Function | E_Generic_Function or else (Ekind (E) = E_Subprogram_Type and then Etype (E) /= Standard_Void_Type) then @@ -8734,9 +8711,9 @@ package body Exp_Ch6 is -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). - if Nkind_In (Func_Call, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind (Func_Call) in N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion then Func_Call := Expression (Func_Call); end if; @@ -8857,8 +8834,8 @@ package body Exp_Ch6 is Temp_Init := Relocate_Node (Allocator); - if Nkind_In (Function_Call, N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind (Function_Call) in + N_Type_Conversion | N_Unchecked_Type_Conversion then Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init); end if; @@ -8903,8 +8880,8 @@ package body Exp_Ch6 is -- that the full types will be compatible, but the types not visibly -- compatible. - elsif Nkind_In (Function_Call, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Function_Call) + in N_Type_Conversion | N_Unchecked_Type_Conversion then Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call); end if; @@ -9368,7 +9345,7 @@ package body Exp_Ch6 is begin while Present (N) - and then Nkind_In (N, N_Attribute_Reference, N_Pragma) + and then Nkind (N) in N_Attribute_Reference | N_Pragma loop Analyze (N); D := N; @@ -9590,8 +9567,8 @@ package body Exp_Ch6 is Set_Etype (Def_Id, Ptr_Typ); Set_Is_Known_Non_Null (Def_Id); - if Nkind_In (Function_Call, N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind (Function_Call) in N_Type_Conversion + | N_Unchecked_Type_Conversion then Res_Decl := Make_Object_Declaration (Loc, @@ -9715,8 +9692,7 @@ package body Exp_Ch6 is -- declaration. Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call); - Set_Directly_Designated_Type (Anon_Type, - Designated_Type (Etype (Allocator))); + Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call)); Set_Etype (Anon_Type, Anon_Type); Build_Class_Wide_Master (Anon_Type); @@ -9732,6 +9708,12 @@ package body Exp_Ch6 is New_Occurrence_Of (Etype (BIP_Func_Call), Loc), Expression => New_Copy_Tree (BIP_Func_Call)))); + -- Manually set the associated node for the anonymous access type to + -- be its local declaration, to avoid confusing and complicating + -- the accessibility machinery. + + Set_Associated_Node_For_Itype (Anon_Type, Tmp_Decl); + Expander_Mode_Save_And_Set (False); Insert_Action (Allocator, Tmp_Decl); Expander_Mode_Restore; @@ -9740,7 +9722,12 @@ package body Exp_Ch6 is (Allocator => Expression (Tmp_Decl), Function_Call => Expression (Expression (Tmp_Decl))); - Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc)); + -- Add a conversion to displace the pointer to the allocated object + -- to reference the corresponding dispatch table. + + Rewrite (Allocator, + Convert_To (Etype (Allocator), + New_Occurrence_Of (Tmp_Id, Loc))); end Make_Build_In_Place_Iface_Call_In_Allocator; --------------------------------------------------------- @@ -10229,7 +10216,7 @@ package body Exp_Ch6 is -- Mark the label of a source or internally generated block or -- loop. - if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then + if Nkind (P) in N_Block_Statement | N_Loop_Statement then Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P))); -- Mark the enclosing function @@ -10276,18 +10263,18 @@ package body Exp_Ch6 is -- Recurse to handle case of multiple levels of qualification and/or -- conversion. - if Nkind_In (Expr, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind (Expr) in N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion then return Unqual_BIP_Function_Call (Expression (Expr)); -- Recurse to handle case of multiple levels of references and -- explicit dereferences. - elsif Nkind_In (Expr, N_Attribute_Reference, - N_Explicit_Dereference, - N_Reference) + elsif Nkind (Expr) in N_Attribute_Reference + | N_Explicit_Dereference + | N_Reference then return Unqual_BIP_Function_Call (Prefix (Expr)); @@ -10295,7 +10282,7 @@ package body Exp_Ch6 is elsif Nkind (Expr) = N_Identifier and then Present (Entity (Expr)) - and then Ekind_In (Entity (Expr), E_Constant, E_Variable) + and then Ekind (Entity (Expr)) in E_Constant | E_Variable and then Nkind (Parent (Entity (Expr))) = N_Object_Renaming_Declaration and then Present (Renamed_Object (Entity (Expr))) @@ -10308,7 +10295,7 @@ package body Exp_Ch6 is elsif not On_Object_Declaration and then Nkind (Expr) = N_Identifier and then Present (Entity (Expr)) - and then Ekind_In (Entity (Expr), E_Constant, E_Variable) + and then Ekind (Entity (Expr)) in E_Constant | E_Variable and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration and then Present (Expression (Parent (Entity (Expr)))) then diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index bd7a1e4..07640bf 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1343,8 +1343,8 @@ package body Exp_Ch7 is -- Treat use clauses as declarations and insert directly in front -- of them. - if Nkind_In (Insertion_Node, N_Use_Package_Clause, - N_Use_Type_Clause) + if Nkind (Insertion_Node) in + N_Use_Package_Clause | N_Use_Type_Clause then Insert_List_Before_And_Analyze (Insertion_Node, Actions); else @@ -2050,10 +2050,8 @@ package body Exp_Ch7 is -- freeze node, the body must be inserted directly after the -- construct. - if Nkind_In (Last_Top_Level_Ctrl_Construct, - N_Freeze_Entity, - N_Package_Declaration, - N_Package_Body) + if Nkind (Last_Top_Level_Ctrl_Construct) in + N_Freeze_Entity | N_Package_Declaration | N_Package_Body then Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct; end if; @@ -2845,11 +2843,8 @@ package body Exp_Ch7 is Result := Next (Stmt); while Present (Result) loop - if not Nkind_In (Result, N_Call_Marker, - N_Raise_Program_Error) - then - exit; - end if; + exit when Nkind (Result) not in + N_Call_Marker | N_Raise_Program_Error; Next (Result); end loop; @@ -3045,7 +3040,7 @@ package body Exp_Ch7 is -- Insert the counter after all initialization has been done. The -- place of insertion depends on the context. - if Ekind_In (Obj_Id, E_Constant, E_Variable) then + if Ekind (Obj_Id) in E_Constant | E_Variable then -- The object is initialized by a build-in-place function call. -- The counter insertion point is after the function call. @@ -3270,7 +3265,7 @@ package body Exp_Ch7 is end; end if; - if Ekind_In (Obj_Id, E_Constant, E_Variable) + if Ekind (Obj_Id) in E_Constant | E_Variable and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) then -- Temporaries created for the purpose of "exporting" a @@ -4361,7 +4356,7 @@ package body Exp_Ch7 is if Is_Subprogram (E) then return True; - elsif Ekind_In (E, E_Block, E_Loop) + elsif Ekind (E) in E_Block | E_Loop and then Contains_Subprogram (E) then return True; @@ -4393,7 +4388,7 @@ package body Exp_Ch7 is Ftyp := Etype (Fent); - if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then + if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then Atyp := Entity (Subtype_Mark (Arg)); else Atyp := Etype (Arg); @@ -4414,7 +4409,7 @@ package body Exp_Ch7 is -- Make_Init_Call, set the target type to the type of the formal -- directly, to avoid spurious typing problems. - elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion) + elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion and then not Is_Class_Wide_Type (Atyp) then Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); @@ -4633,12 +4628,12 @@ package body Exp_Ch7 is function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is begin - return Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Function, - E_Package, - E_Procedure, - E_Subprogram_Body); + return Ekind (Id) in E_Entry + | E_Entry_Family + | E_Function + | E_Package + | E_Procedure + | E_Subprogram_Body; end Is_Package_Or_Subprogram; -- Local variables @@ -4711,11 +4706,12 @@ package body Exp_Ch7 is ---------------------------- procedure Expand_Cleanup_Actions (N : Node_Id) is - pragma Assert (Nkind_In (N, N_Block_Statement, - N_Entry_Body, - N_Extended_Return_Statement, - N_Subprogram_Body, - N_Task_Body)); + pragma Assert + (Nkind (N) in N_Block_Statement + | N_Entry_Body + | N_Extended_Return_Statement + | N_Subprogram_Body + | N_Task_Body); Scop : constant Entity_Id := Current_Scope; @@ -5305,9 +5301,8 @@ package body Exp_Ch7 is -- of the alternative. if Nkind (Parent (Curr)) = N_Entry_Call_Alternative - and then Nkind_In (Parent (Parent (Curr)), - N_Conditional_Entry_Call, - N_Timed_Entry_Call) + and then Nkind (Parent (Parent (Curr))) in + N_Conditional_Entry_Call | N_Timed_Entry_Call then return Parent (Parent (Curr)); @@ -5648,7 +5643,7 @@ package body Exp_Ch7 is -- <or> -- Hook := Obj_Id'Unrestricted_Access; - if Ekind_In (Obj_Id, E_Constant, E_Variable) + if Ekind (Obj_Id) in E_Constant | E_Variable and then Present (Last_Aggregate_Assignment (Obj_Id)) then Hook_Insert := Last_Aggregate_Assignment (Obj_Id); @@ -9012,10 +9007,9 @@ package body Exp_Ch7 is Par : Node_Id := Parent (N); begin - while not (Nkind_In (Par, N_Handled_Sequence_Of_Statements, - N_Loop_Statement, - N_Package_Specification) - or else Nkind (Par) in N_Proper_Body) + while Nkind (Par) not in + N_Handled_Sequence_Of_Statements | N_Loop_Statement | + N_Package_Specification | N_Proper_Body loop pragma Assert (Present (Par)); Par := Parent (Par); @@ -9102,12 +9096,12 @@ package body Exp_Ch7 is -- Prevent the search from going too far because transient blocks -- are bounded by packages and subprogram scopes. - elsif Ekind_In (Scop, E_Entry, - E_Entry_Family, - E_Function, - E_Package, - E_Procedure, - E_Subprogram_Body) + elsif Ekind (Scop) in E_Entry + | E_Entry_Family + | E_Function + | E_Package + | E_Procedure + | E_Subprogram_Body then exit; end if; @@ -9398,7 +9392,7 @@ package body Exp_Ch7 is Manage_SS => Uses_Sec_Stack (Curr_S) and then Nkind (N) = N_Object_Declaration - and then Ekind_In (Encl_S, E_Package, E_Package_Body) + and then Ekind (Encl_S) in E_Package | E_Package_Body and then Is_Library_Level_Entity (Encl_S)); Pop_Scope; diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 4498be5..630d62f 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -125,7 +125,7 @@ package body Exp_Ch8 is if Modify_Tree_For_C then return True; - elsif Nkind_In (Nam, N_Indexed_Component, N_Slice) then + elsif Nkind (Nam) in N_Indexed_Component | N_Slice then if Is_Packed (Etype (Prefix (Nam))) then return True; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index c4b9882..9cf90d1 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -1248,9 +1248,8 @@ package body Exp_Ch9 is -- and the environment task is our effective master, -- so nothing to mark. - if Nkind_In (Par, N_Block_Statement, - N_Subprogram_Body, - N_Task_Body) + if Nkind (Par) in + N_Block_Statement | N_Subprogram_Body | N_Task_Body then Set_Is_Task_Master (Par); exit; @@ -1460,8 +1459,8 @@ package body Exp_Ch9 is Prag := Pre_Post_Conditions (Items); while Present (Prag) loop - if Nam_In (Pragma_Name_Unmapped (Prag), - Name_Postcondition, Name_Precondition) + if Pragma_Name_Unmapped (Prag) in Name_Postcondition + | Name_Precondition and then Is_Checked (Prag) then Has_Pragma := True; @@ -3185,10 +3184,8 @@ package body Exp_Ch9 is and then ((Nkind (N) = N_Simple_Return_Statement and then N /= Last (Stmts)) or else Nkind (N) = N_Extended_Return_Statement - or else (Nkind_In (N, N_Raise_Constraint_Error, - N_Raise_Program_Error, - N_Raise_Statement, - N_Raise_Storage_Error) + or else (Nkind (N) in + N_Raise_xxx_Error | N_Raise_Statement and then Comes_From_Source (N))) then Wrap_Statement (N); @@ -3537,9 +3534,8 @@ package body Exp_Ch9 is while Present (Context) and then Nkind (Context) /= N_Compilation_Unit loop - if Nkind_In (Context, N_Block_Statement, - N_Subprogram_Body, - N_Task_Body) + if Nkind (Context) in + N_Block_Statement | N_Subprogram_Body | N_Task_Body then Set_Is_Task_Master (Context); exit; @@ -3576,8 +3572,40 @@ package body Exp_Ch9 is if Present (Ins_Nod) then Context := Ins_Nod; + elsif Is_Itype (Ptr_Typ) then Context := Associated_Node_For_Itype (Ptr_Typ); + + -- When the context references a discriminant or a component of a + -- private type and we are processing declarations in the private + -- part of the enclosing package, we must insert the master renaming + -- before the full declaration of the private type; otherwise the + -- master renaming would be inserted in the public part of the + -- package (and hence before the declaration of _master). + + if In_Private_Part (Current_Scope) then + declare + Ctx : Node_Id := Context; + + begin + if Nkind (Context) = N_Discriminant_Specification then + Ctx := Parent (Ctx); + else + while Nkind (Ctx) in + N_Component_Declaration | N_Component_List + loop + Ctx := Parent (Ctx); + end loop; + end if; + + if Nkind (Ctx) in N_Private_Type_Declaration + | N_Private_Extension_Declaration + then + Context := Parent (Full_View (Defining_Identifier (Ctx))); + end if; + end; + end if; + else Context := Parent (Ptr_Typ); end if; @@ -5543,7 +5571,7 @@ package body Exp_Ch9 is -- _object : prot_typVP := prot_typV (_O); -- subtype Jnn is <Type of Index> range Low .. High; - if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then + if Nkind (Decl) in N_Full_Type_Declaration | N_Object_Declaration then Set_Debug_Info_Needed (Defining_Identifier (Decl)); -- Declaration for the Protection object, discriminals, privals, and @@ -6156,7 +6184,7 @@ package body Exp_Ch9 is if Is_Static_Expression (N) then return True; elsif Ada_Version >= Ada_2020 - and then Nkind_In (N, N_Selected_Component, N_Indexed_Component) + and then Nkind (N) in N_Selected_Component | N_Indexed_Component and then Statically_Names_Object (N) then -- Restriction relaxed in Ada2020 to allow statically named @@ -6660,6 +6688,7 @@ package body Exp_Ch9 is -- must be properly set. Set_Parent (Block, Parent (N)); + Set_Parent (Blkent, Block); -- Prepend call to Accept_Call to main statement sequence If the -- accept has exception handlers, the statement sequence is wrapped @@ -7097,8 +7126,8 @@ package body Exp_Ch9 is if Nkind (Ecall) = N_Block_Statement then Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); - while not Nkind_In (Ecall, N_Procedure_Call_Statement, - N_Entry_Call_Statement) + while Nkind (Ecall) not in + N_Procedure_Call_Statement | N_Entry_Call_Statement loop Next (Ecall); end loop; @@ -7111,9 +7140,8 @@ package body Exp_Ch9 is if Ada_Version >= Ada_2005 and then (No (Original_Node (Ecall)) - or else not Nkind_In (Original_Node (Ecall), - N_Delay_Relative_Statement, - N_Delay_Until_Statement)) + or else Nkind (Original_Node (Ecall)) not in + N_Delay_Relative_Statement | N_Delay_Until_Statement) then Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); @@ -10075,8 +10103,7 @@ package body Exp_Ch9 is Acc_Ent := N; while Present (Acc_Ent) - and then not Nkind_In (Acc_Ent, N_Accept_Statement, - N_Entry_Body) + and then Nkind (Acc_Ent) not in N_Accept_Statement | N_Entry_Body loop Acc_Ent := Parent (Acc_Ent); end loop; @@ -12490,7 +12517,7 @@ package body Exp_Ch9 is begin Ent := First_Entity (Tasktyp); while Present (Ent) loop - if Ekind_In (Ent, E_Entry, E_Entry_Family) then + if Ekind (Ent) in E_Entry | E_Entry_Family then Build_Contract_Wrapper (Ent, N); end if; @@ -12613,8 +12640,6 @@ package body Exp_Ch9 is -- global references if within an instantiation. procedure Expand_N_Timed_Entry_Call (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Actuals : List_Id; Blk_Typ : Entity_Id; Call : Node_Id; @@ -12637,6 +12662,7 @@ package body Exp_Ch9 is Index : Node_Id; Is_Disp_Select : Boolean; Lim_Typ_Stmts : List_Id; + Loc : constant Source_Ptr := Sloc (D_Stat); N_Stats : List_Id; Obj : Entity_Id; Param : Node_Id; @@ -12681,8 +12707,8 @@ package body Exp_Ch9 is if Nkind (E_Call) = N_Block_Statement then E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); - while not Nkind_In (E_Call, N_Procedure_Call_Statement, - N_Entry_Call_Statement) + while Nkind (E_Call) not in + N_Procedure_Call_Statement | N_Entry_Call_Statement loop Next (E_Call); end loop; @@ -13385,12 +13411,12 @@ package body Exp_Ch9 is Context := Parent (N); while Present (Context) loop - if Nkind_In (Context, N_Entry_Body, - N_Extended_Return_Statement, - N_Package_Body, - N_Package_Declaration, - N_Subprogram_Body, - N_Task_Body) + if Nkind (Context) in N_Entry_Body + | N_Extended_Return_Statement + | N_Package_Body + | N_Package_Declaration + | N_Subprogram_Body + | N_Task_Body then exit; @@ -13519,7 +13545,7 @@ package body Exp_Ch9 is begin First_Op := First (D); while Present (First_Op) - and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) + and then Nkind (First_Op) not in N_Subprogram_Body | N_Entry_Body loop Next (First_Op); end loop; @@ -13997,8 +14023,8 @@ package body Exp_Ch9 is -- of this type should have been removed during semantic analysis. Pdec := Parent (Ptyp); - while not Nkind_In (Pdec, N_Protected_Type_Declaration, - N_Single_Protected_Declaration) + while Nkind (Pdec) not in + N_Protected_Type_Declaration | N_Single_Protected_Declaration loop Next (Pdec); end loop; @@ -14429,8 +14455,8 @@ package body Exp_Ch9 is -- this type should have been removed during semantic analysis. Tdec := Parent (Ttyp); - while not Nkind_In (Tdec, N_Task_Type_Declaration, - N_Single_Task_Declaration) + while Nkind (Tdec) not in + N_Task_Type_Declaration | N_Single_Task_Declaration loop Next (Tdec); end loop; @@ -14779,8 +14805,8 @@ package body Exp_Ch9 is Next_Op := Next (N); while Present (Next_Op) - and then not Nkind_In (Next_Op, - N_Subprogram_Body, N_Entry_Body, N_Expression_Function) + and then Nkind (Next_Op) not in + N_Subprogram_Body | N_Entry_Body | N_Expression_Function loop Next (Next_Op); end loop; @@ -14798,14 +14824,13 @@ package body Exp_Ch9 is begin Stmt := First (Stats); while Nkind (Stmt) /= N_Empty - and then (Nkind_In (Stmt, N_Null_Statement, N_Label) + and then (Nkind (Stmt) in N_Null_Statement | N_Label or else (Nkind (Stmt) = N_Pragma and then - Nam_In (Pragma_Name_Unmapped (Stmt), - Name_Unreferenced, - Name_Unmodified, - Name_Warnings))) + Pragma_Name_Unmapped (Stmt) in Name_Unreferenced + | Name_Unmodified + | Name_Warnings)) loop Next (Stmt); end loop; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index fb79cb5..b973fb6 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -424,7 +424,7 @@ package body Exp_Dbug is -- anyway, so the renaming entity will be available in -- debuggers. - exit when not Ekind_In (Sel_Id, E_Component, E_Discriminant); + exit when Ekind (Sel_Id) not in E_Component | E_Discriminant; First_Bit := Normalized_First_Bit (Sel_Id); Enable := @@ -839,11 +839,11 @@ package body Exp_Dbug is -- Case of interface name being used - if Ekind_In (E, E_Constant, - E_Exception, - E_Function, - E_Procedure, - E_Variable) + if Ekind (E) in E_Constant + | E_Exception + | E_Function + | E_Procedure + | E_Variable and then Present (Interface_Name (E)) and then No (Address_Clause (E)) and then not Has_Suffix @@ -874,7 +874,7 @@ package body Exp_Dbug is if Is_Generic_Instance (E) and then Is_Subprogram (E) and then not Is_Compilation_Unit (Scope (E)) - and then Ekind_In (Scope (E), E_Package, E_Package_Body) + and then Ekind (Scope (E)) in E_Package | E_Package_Body and then Present (Related_Instance (Scope (E))) then E := Related_Instance (Scope (E)); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 89f206e..1a41d79 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -389,8 +389,8 @@ package body Exp_Disp is -- Handle full type declarations and derivations of library level -- tagged types - elsif Nkind_In (D, N_Full_Type_Declaration, - N_Derived_Type_Definition) + elsif Nkind (D) in + N_Full_Type_Declaration | N_Derived_Type_Definition and then Is_Library_Level_Tagged_Type (Defining_Entity (D)) and then Ekind (Defining_Entity (D)) /= E_Record_Subtype and then not Is_Private_Type (Defining_Entity (D)) @@ -1223,9 +1223,8 @@ package body Exp_Disp is -- the corresponding object or parameter declaration elsif Nkind (Controlling_Tag) = N_Identifier - and then Nkind_In (Parent (Entity (Controlling_Tag)), - N_Object_Declaration, - N_Parameter_Specification) + and then Nkind (Parent (Entity (Controlling_Tag))) in + N_Object_Declaration | N_Parameter_Specification then Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Entity (Controlling_Tag))); @@ -1235,9 +1234,8 @@ package body Exp_Disp is elsif Nkind (Controlling_Tag) = N_Explicit_Dereference and then Nkind (Prefix (Controlling_Tag)) = N_Identifier - and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))), - N_Object_Declaration, - N_Parameter_Specification) + and then Nkind (Parent (Entity (Prefix (Controlling_Tag)))) in + N_Object_Declaration | N_Parameter_Specification then Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Entity (Prefix (Controlling_Tag)))); @@ -8562,7 +8560,7 @@ package body Exp_Disp is -- Propagate the value to the wrapped subprogram (if one is present) - if Ekind_In (Prim, E_Function, E_Procedure) + if Ekind (Prim) in E_Function | E_Procedure and then Is_Primitive_Wrapper (Prim) and then Present (Wrapped_Entity (Prim)) and then Is_Dispatching_Operation (Wrapped_Entity (Prim)) @@ -8595,7 +8593,7 @@ package body Exp_Disp is -- Propagate the value to the wrapped subprogram (if one is present) - if Ekind_In (Prim, E_Function, E_Procedure) + if Ekind (Prim) in E_Function | E_Procedure and then Is_Primitive_Wrapper (Prim) and then Present (Wrapped_Entity (Prim)) and then Is_Dispatching_Operation (Wrapped_Entity (Prim)) @@ -8732,7 +8730,7 @@ package body Exp_Disp is -- If the DTC_Entity attribute is already set we can also output -- the name of the interface covered by this primitive (if any). - if Ekind_In (Alias (Prim), E_Function, E_Procedure) + if Ekind (Alias (Prim)) in E_Function | E_Procedure and then Present (DTC_Entity (Alias (Prim))) and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) then diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 8cad102..41e4b1b 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -483,7 +483,7 @@ package body Exp_Imgv is -- underlying type. if Ada_Version >= Ada_2020 then - Rtyp := Underlying_Type (Ptyp); + Rtyp := Underlying_Type (Root_Type (Ptyp)); else Rtyp := Root_Type (Ptyp); end if; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 12dcbae..04ad92b 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -138,7 +138,7 @@ package body Exp_Intr is Ent : Entity_Id := Current_Scope; begin while Present (Ent) loop - exit when not Ekind_In (Ent, E_Block, E_Loop); + exit when Ekind (Ent) not in E_Block | E_Loop; Ent := Scope (Ent); end loop; @@ -627,9 +627,9 @@ package body Exp_Intr is elsif Nam = Name_Generic_Dispatching_Constructor then Expand_Dispatching_Constructor_Call (N); - elsif Nam_In (Nam, Name_Import_Address, - Name_Import_Largest_Value, - Name_Import_Value) + elsif Nam in Name_Import_Address + | Name_Import_Largest_Value + | Name_Import_Value then Expand_Import_Call (N); @@ -663,19 +663,19 @@ package body Exp_Intr is elsif Nam = Name_To_Pointer then Expand_To_Pointer (N); - elsif Nam_In (Nam, Name_File, - Name_Line, - Name_Source_Location, - Name_Enclosing_Entity, - Name_Compilation_ISO_Date, - Name_Compilation_Date, - Name_Compilation_Time) + elsif Nam in Name_File + | Name_Line + | Name_Source_Location + | Name_Enclosing_Entity + | Name_Compilation_ISO_Date + | Name_Compilation_Date + | Name_Compilation_Time then Expand_Source_Info (N, Nam); - -- If we have a renaming, expand the call to the original operation, - -- which must itself be intrinsic, since renaming requires matching - -- conventions and this has already been checked. + -- If we have a renaming, expand the call to the original operation, + -- which must itself be intrinsic, since renaming requires matching + -- conventions and this has already been checked. elsif Present (Alias (E)) then Expand_Intrinsic_Call (N, Alias (E)); @@ -683,10 +683,10 @@ package body Exp_Intr is elsif Nkind (N) in N_Binary_Op then Expand_Binary_Operator_Call (N); - -- The only other case is where an external name was specified, since - -- this is the only way that an otherwise unrecognized name could - -- escape the checking in Sem_Prag. Nothing needs to be done in such - -- a case, since we pass such a call to the back end unchanged. + -- The only other case is where an external name was specified, since + -- this is the only way that an otherwise unrecognized name could + -- escape the checking in Sem_Prag. Nothing needs to be done in such + -- a case, since we pass such a call to the back end unchanged. else null; diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 6d5cf62..b95bd32 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -469,7 +469,7 @@ package body Exp_Pakd is or else (Nkind (Aexp) = N_Indexed_Component and then Is_Entity_Name (Prefix (Aexp))) - or else Nkind_In (Aexp, N_Explicit_Dereference, N_Function_Call) + or else Nkind (Aexp) in N_Explicit_Dereference | N_Function_Call then Set_Analyzed (Aexp); end if; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index bfedae5..e978595 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -61,9 +61,7 @@ package body Exp_Prag is -- Local Subprograms -- ----------------------- - function Arg1 (N : Node_Id) return Node_Id; - function Arg2 (N : Node_Id) return Node_Id; - function Arg3 (N : Node_Id) return Node_Id; + function Arg_N (N : Node_Id; Arg_Number : Positive) return Node_Id; -- Obtain specified pragma argument expression procedure Expand_Pragma_Abort_Defer (N : Node_Id); @@ -84,13 +82,24 @@ package body Exp_Prag is -- these cases we want no initialization to occur, but we have already done -- the initialization by the time we see the pragma, so we have to undo it. - ---------- - -- Arg1 -- - ---------- + ----------- + -- Arg_N -- + ----------- - function Arg1 (N : Node_Id) return Node_Id is - Arg : constant Node_Id := First (Pragma_Argument_Associations (N)); + function Arg_N (N : Node_Id; Arg_Number : Positive) return Node_Id is + Arg : Node_Id := First (Pragma_Argument_Associations (N)); begin + if No (Arg) then + return Empty; + end if; + + for J in 2 .. Arg_Number loop + Next (Arg); + if No (Arg) then + return Empty; + end if; + end loop; + if Present (Arg) and then Nkind (Arg) = N_Pragma_Argument_Association then @@ -98,66 +107,7 @@ package body Exp_Prag is else return Arg; end if; - end Arg1; - - ---------- - -- Arg2 -- - ---------- - - function Arg2 (N : Node_Id) return Node_Id is - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - - begin - if No (Arg1) then - return Empty; - - else - declare - Arg : constant Node_Id := Next (Arg1); - begin - if Present (Arg) - and then Nkind (Arg) = N_Pragma_Argument_Association - then - return Expression (Arg); - else - return Arg; - end if; - end; - end if; - end Arg2; - - ---------- - -- Arg3 -- - ---------- - - function Arg3 (N : Node_Id) return Node_Id is - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - - begin - if No (Arg1) then - return Empty; - - else - declare - Arg : Node_Id := Next (Arg1); - begin - if No (Arg) then - return Empty; - - else - Next (Arg); - - if Present (Arg) - and then Nkind (Arg) = N_Pragma_Argument_Association - then - return Expression (Arg); - else - return Arg; - end if; - end if; - end; - end if; - end Arg3; + end Arg_N; --------------------- -- Expand_N_Pragma -- @@ -317,8 +267,8 @@ package body Exp_Prag is -------------------------- procedure Expand_Pragma_Check (N : Node_Id) is - Cond : constant Node_Id := Arg2 (N); - Nam : constant Name_Id := Chars (Arg1 (N)); + Cond : constant Node_Id := Arg_N (N, 2); + Nam : constant Name_Id := Chars (Arg_N (N, 1)); Msg : Node_Id; Loc : constant Source_Ptr := Sloc (First_Node (Cond)); @@ -477,7 +427,7 @@ package body Exp_Prag is if ((Debug_Flag_Dot_G or else Restriction_Active (No_Exception_Propagation)) and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) - or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) + or else (Opt.Exception_Locations_Suppressed and then No (Arg_N (N, 3))) then Rewrite (N, Make_If_Statement (Loc, @@ -491,8 +441,8 @@ package body Exp_Prag is else -- If we have a message given, use it - if Present (Arg3 (N)) then - Msg := Get_Pragma_Arg (Arg3 (N)); + if Present (Arg_N (N, 3)) then + Msg := Get_Pragma_Arg (Arg_N (N, 3)); -- Here we have no string, so prepare one @@ -520,7 +470,7 @@ package body Exp_Prag is -- that the failure is not at the point of occurrence of the -- pragma, unlike the other Check cases. - elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then + elsif Nam in Name_Precondition | Name_Postcondition then Get_Name_String (Nam); Insert_Str_In_Name_Buffer ("failed ", 1); Add_Str_To_Name_Buffer (" from "); @@ -615,8 +565,8 @@ package body Exp_Prag is procedure Expand_Pragma_Common_Object (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Internal : constant Node_Id := Arg1 (N); - External : constant Node_Id := Arg2 (N); + Internal : constant Node_Id := Arg_N (N, 1); + External : constant Node_Id := Arg_N (N, 2); Psect : Node_Id; -- Psect value upper cased as string literal @@ -1380,11 +1330,11 @@ package body Exp_Prag is if Relaxed_RM_Semantics and then List_Length (Pragma_Argument_Associations (N)) = 2 and then Pragma_Name (N) = Name_Import - and then Nkind (Arg2 (N)) = N_String_Literal + and then Nkind (Arg_N (N, 2)) = N_String_Literal then - Def_Id := Entity (Arg1 (N)); + Def_Id := Entity (Arg_N (N, 1)); else - Def_Id := Entity (Arg2 (N)); + Def_Id := Entity (Arg_N (N, 2)); end if; -- Variable case (we have to undo any initialization already done) @@ -1401,7 +1351,7 @@ package body Exp_Prag is declare Loc : constant Source_Ptr := Sloc (N); - Rtti_Name : constant Node_Id := Arg3 (N); + Rtti_Name : constant Node_Id := Arg_N (N, 3); Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); Exdata : List_Id; Lang_Char : Node_Id; @@ -2219,7 +2169,9 @@ package body Exp_Prag is (Make_Function_Call (Loc, New_Occurrence_Of (RTE (RE_Clock), Loc)))), Right_Opnd => - Unchecked_Convert_To (Standard_Duration, Arg1 (N))))))); + Unchecked_Convert_To ( + Standard_Duration, + Arg_N (N, 1))))))); Analyze (N); end if; @@ -2230,7 +2182,7 @@ package body Exp_Prag is ------------------------------------------- procedure Expand_Pragma_Suppress_Initialization (N : Node_Id) is - Def_Id : constant Entity_Id := Entity (Arg1 (N)); + Def_Id : constant Entity_Id := Entity (Arg_N (N, 1)); begin -- Variable case (we have to undo any initialization already done) diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index d550a1d..80b49a7 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -520,8 +520,8 @@ package body Exp_Put_Image is Decl : out Node_Id; Pnam : out Entity_Id) is - pragma Assert (Typ = Base_Type (Typ)); - pragma Assert (not Is_Unchecked_Union (Typ)); + Btyp : constant Entity_Id := Base_Type (Typ); + pragma Assert (not Is_Unchecked_Union (Btyp)); First_Time : Boolean := True; @@ -645,8 +645,8 @@ package body Exp_Put_Image is -- with no components there is no need to handle it. while Present (Item) loop - if Nkind_In (Item, N_Component_Declaration, - N_Discriminant_Specification) + if Nkind (Item) in + N_Component_Declaration | N_Discriminant_Specification and then ((Chars (Defining_Identifier (Item)) = Name_uParent and then not Is_Interface @@ -694,7 +694,7 @@ package body Exp_Put_Image is Stms : constant List_Id := New_List; Rdef : Node_Id; Type_Decl : constant Node_Id := - Declaration_Node (Base_Type (Underlying_Type (Typ))); + Declaration_Node (Base_Type (Underlying_Type (Btyp))); -- Start of processing for Build_Record_Put_Image_Procedure @@ -732,8 +732,8 @@ package body Exp_Put_Image is Parameter_Associations => New_List (Make_Identifier (Loc, Name_S)))); - Pnam := Make_Put_Image_Name (Loc, Typ); - Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms); + Pnam := Make_Put_Image_Name (Loc, Btyp); + Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms); end Build_Record_Put_Image_Procedure; ------------------------------- diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb index adce44a..fa4aeb6 100644 --- a/gcc/ada/exp_smem.adb +++ b/gcc/ada/exp_smem.adb @@ -372,7 +372,7 @@ package body Exp_Smem is return False; else - if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then + if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter then Insert_Node := Call; return True; else @@ -477,7 +477,7 @@ package body Exp_Smem is return False; end if; - elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component) + elsif Nkind (P) in N_Indexed_Component | N_Selected_Component and then N = Prefix (P) then return On_Lhs_Of_Assignment (P); diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 40621bd..b400268 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -227,9 +227,9 @@ package body Exp_SPARK is if Nkind (Index) = N_Range then Apply_Scalar_Range_Check - (Low_Bound (Index), Etype (Index_Typ)); + (Low_Bound (Index), Base_Type (Etype (Index_Typ))); Apply_Scalar_Range_Check - (High_Bound (Index), Etype (Index_Typ)); + (High_Bound (Index), Base_Type (Etype (Index_Typ))); -- Otherwise the index denotes a single element @@ -400,13 +400,16 @@ package body Exp_SPARK is -- flag as the compiler assumes attributes always fit in this type. -- Since in SPARK_Mode we do not take Storage_Error into account, we -- cannot make this assumption and need to produce a check. - -- ??? It should be enough to add this check for attributes 'Length - -- and 'Range_Length when the type is as big as Long_Long_Integer. + -- ??? It should be enough to add this check for attributes + -- 'Length, 'Range_Length and 'Pos when the type is as big + -- as Long_Long_Integer. declare Typ : Entity_Id; begin - if Attr_Id = Attribute_Range_Length then + if Attr_Id = Attribute_Range_Length + or else Attr_Id = Attribute_Pos + then Typ := Etype (Prefix (N)); elsif Attr_Id = Attribute_Length then @@ -421,6 +424,9 @@ package body Exp_SPARK is if Present (Typ) and then RM_Size (Typ) = RM_Size (Standard_Long_Long_Integer) then + -- ??? This should rather be a range check, but this would + -- crash GNATprove which somehow recovers the proper kind + -- of check anyway. Set_Do_Overflow_Check (N); end if; end; diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index fc2338f..b640843 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -291,12 +291,12 @@ package body Exp_Tss is then exit; - elsif Ekind_In (Etype (E1), - E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type) - and then Ekind_In (Etype (E2), - E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type) + elsif Ekind (Etype (E1)) in + E_Anonymous_Access_Subprogram_Type | + E_Anonymous_Access_Protected_Subprogram_Type + and then Ekind (Etype (E2)) in + E_Anonymous_Access_Subprogram_Type | + E_Anonymous_Access_Protected_Subprogram_Type and then not Conforming_Types (Etype (E1), Etype (E2), Fully_Conformant) then diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index e530a94..ffc30c3 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -471,21 +471,23 @@ package body Exp_Unst is Callee : Entity_Id; procedure Check_Static_Type - (T : Entity_Id; + (In_T : Entity_Id; N : Node_Id; DT : in out Boolean; Check_Designated : Boolean := False); - -- Given a type T, checks if it is a static type defined as a type - -- with no dynamic bounds in sight. If so, the only action is to - -- set Is_Static_Type True for T. If T is not a static type, then - -- all types with dynamic bounds associated with T are detected, - -- and their bounds are marked as uplevel referenced if not at the - -- library level, and DT is set True. If N is specified, it's the - -- node that will need to be replaced. If not specified, it means - -- we can't do a replacement because the bound is implicit. - - -- If Check_Designated is True and T or its full view is an access - -- type, check whether the designated type has dynamic bounds. + -- Given a type In_T, checks if it is a static type defined as + -- a type with no dynamic bounds in sight. If so, the only + -- action is to set Is_Static_Type True for In_T. If In_T is + -- not a static type, then all types with dynamic bounds + -- associated with In_T are detected, and their bounds are + -- marked as uplevel referenced if not at the library level, + -- and DT is set True. If N is specified, it's the node that + -- will need to be replaced. If not specified, it means we + -- can't do a replacement because the bound is implicit. + + -- If Check_Designated is True and In_T or its full view + -- is an access type, check whether the designated type + -- has dynamic bounds. procedure Note_Uplevel_Ref (E : Entity_Id; @@ -505,11 +507,13 @@ package body Exp_Unst is ----------------------- procedure Check_Static_Type - (T : Entity_Id; + (In_T : Entity_Id; N : Node_Id; DT : in out Boolean; Check_Designated : Boolean := False) is + T : constant Entity_Id := Get_Fullest_View (In_T); + procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id); -- N is the bound of a dynamic type. This procedure notes that -- this bound is uplevel referenced, it can handle references @@ -546,8 +550,8 @@ package body Exp_Unst is -- Attribute or indexed component case - elsif Nkind_In (N, N_Attribute_Reference, - N_Indexed_Component) + elsif Nkind (N) in + N_Attribute_Reference | N_Indexed_Component then Note_Uplevel_Bound (Prefix (N), Ref); @@ -601,8 +605,8 @@ package body Exp_Unst is -- Explicit dereference and selected component case - elsif Nkind_In (N, N_Explicit_Dereference, - N_Selected_Component) + elsif Nkind (N) in + N_Explicit_Dereference | N_Selected_Component then Note_Uplevel_Bound (Prefix (N), Ref); @@ -786,7 +790,7 @@ package body Exp_Unst is then return; - elsif Ekind_In (Callee, E_Entry, E_Entry_Family) then + elsif Ekind (Callee) in E_Entry | E_Entry_Family then return; end if; @@ -1271,9 +1275,9 @@ package body Exp_Unst is -- references to global declarations. and then - (Ekind_In (Ent, E_Constant, - E_Loop_Parameter, - E_Variable) + (Ekind (Ent) in E_Constant + | E_Loop_Parameter + | E_Variable -- Formals are interesting, but not if being used -- as mere names of parameters for name notation @@ -2131,9 +2135,9 @@ package body Exp_Unst is -- N_Loop_Parameter_Specification or to -- an N_Iterator_Specification. - if Nkind_In - (Ins, N_Iterator_Specification, - N_Loop_Parameter_Specification) + if Nkind (Ins) in + N_Iterator_Specification | + N_Loop_Parameter_Specification then -- Quantified expression are rewritten as -- loops during expansion. @@ -2366,9 +2370,8 @@ package body Exp_Unst is -- processing this dereference if Opt.Modify_Tree_For_C - and then Nkind_In (Parent (UPJ.Ref), - N_Type_Conversion, - N_Unchecked_Type_Conversion) + and then Nkind (Parent (UPJ.Ref)) in + N_Type_Conversion | N_Unchecked_Type_Conversion then Force_Evaluation (UPJ.Ref, Mode => Strict); end if; @@ -2554,7 +2557,7 @@ package body Exp_Unst is function Search_Subprograms (N : Node_Id) return Traverse_Result is begin - if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then + if Nkind (N) in N_Subprogram_Body | N_Subprogram_Body_Stub then declare Spec_Id : constant Entity_Id := Unique_Defining_Entity (N); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 27609c7..0f8505f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5064,7 +5064,7 @@ package body Exp_Util is ----------------------------------------- procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is - pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant)); + pragma Assert (Nkind (N) in N_Case_Statement_Alternative | N_Variant); Choices : constant List_Id := Discrete_Choices (N); @@ -5842,7 +5842,7 @@ package body Exp_Util is begin S := Scop; while Present (S) loop - if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure) + if Ekind (S) in E_Entry | E_Entry_Family | E_Function | E_Procedure and then Present (Protection_Object (S)) then return Protection_Object (S); @@ -5920,8 +5920,8 @@ package body Exp_Util is Par := N; Top := N; while Present (Par) loop - if Nkind_In (Original_Node (Par), N_Case_Expression, - N_If_Expression) + if Nkind (Original_Node (Par)) in + N_Case_Expression | N_If_Expression then Top := Par; @@ -5942,13 +5942,13 @@ package body Exp_Util is Par := Top; while Present (Par) loop if Is_List_Member (Par) - and then not Nkind_In (Par, N_Component_Association, - N_Discriminant_Association, - N_Parameter_Association, - N_Pragma_Argument_Association) - and then not Nkind_In (Parent (Par), N_Function_Call, - N_Procedure_Call_Statement, - N_Entry_Call_Statement) + and then Nkind (Par) not in N_Component_Association + | N_Discriminant_Association + | N_Parameter_Association + | N_Pragma_Argument_Association + and then Nkind (Parent (Par)) not in N_Function_Call + | N_Procedure_Call_Statement + | N_Entry_Call_Statement then return Par; @@ -5971,7 +5971,7 @@ package body Exp_Util is -- Keep climbing past various operators if Nkind (Parent (Par)) in N_Op - or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else) + or else Nkind (Parent (Par)) in N_And_Then | N_Or_Else then Par := Parent (Par); else @@ -6009,11 +6009,11 @@ package body Exp_Util is while Present (Par) loop if Par = Wrapped_Node - or else Nkind_In (Par, N_Assignment_Statement, - N_Object_Declaration, - N_Pragma, - N_Procedure_Call_Statement, - N_Simple_Return_Statement) + or else Nkind (Par) in N_Assignment_Statement + | N_Object_Declaration + | N_Pragma + | N_Procedure_Call_Statement + | N_Simple_Return_Statement then return Par; @@ -6276,10 +6276,9 @@ package body Exp_Util is -- Deal with conversions, qualifications, and expressions with -- actions. - while Nkind_In (Cond, - N_Type_Conversion, - N_Qualified_Expression, - N_Expression_With_Actions) + while Nkind (Cond) in N_Type_Conversion + | N_Qualified_Expression + | N_Expression_With_Actions loop Cond := Expression (Cond); end loop; @@ -6289,7 +6288,7 @@ package body Exp_Util is -- Deal with AND THEN and AND cases - if Nkind_In (Cond, N_And_Then, N_Op_And) then + if Nkind (Cond) in N_And_Then | N_Op_And then -- Don't ever try to invert a condition that is of the form of an -- AND or AND THEN (since we are not doing sufficiently general @@ -6365,10 +6364,9 @@ package body Exp_Util is return; - elsif Nkind_In (Cond, - N_Type_Conversion, - N_Qualified_Expression, - N_Expression_With_Actions) + elsif Nkind (Cond) in N_Type_Conversion + | N_Qualified_Expression + | N_Expression_With_Actions then Cond := Expression (Cond); @@ -7265,7 +7263,7 @@ package body Exp_Util is -- actions should be inserted outside the complete record -- declaration. - elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then + elsif Nkind (Parent (P)) in N_Variant | N_Record_Definition then null; -- Do not insert freeze nodes within the loop generated for @@ -7346,6 +7344,7 @@ package body Exp_Util is when N_Component_Association | N_Iterated_Component_Association + | N_Iterated_Element_Association => if Nkind (Parent (P)) = N_Aggregate and then Present (Loop_Actions (P)) @@ -7652,8 +7651,8 @@ package body Exp_Util is P := Parent (P); if Is_List_Member (P) then - exit when Nkind_In (Parent (P), N_Package_Specification, - N_Subprogram_Body); + exit when Nkind (Parent (P)) in + N_Package_Specification | N_Subprogram_Body; -- Special handling for handled sequence of statements, we must -- insert in the statements not the exception handlers! @@ -7873,8 +7872,8 @@ package body Exp_Util is if Nkind (Result) = N_Explicit_Dereference then Result := Prefix (Result); - elsif Nkind_In (Result, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Result) in + N_Type_Conversion | N_Unchecked_Type_Conversion then Result := Expression (Result); @@ -8124,7 +8123,7 @@ package body Exp_Util is if Nkind (N) = N_Identifier and then Present (Entity (N)) - and then Ekind_In (Entity (N), E_Constant, E_Variable) + and then Ekind (Entity (N)) in E_Constant | E_Variable then Ren_Obj := Entity (N); return Abandon; @@ -8331,7 +8330,7 @@ package body Exp_Util is end if; return - Ekind_In (Obj_Id, E_Constant, E_Variable) + Ekind (Obj_Id) in E_Constant | E_Variable and then Needs_Finalization (Desig) and then Requires_Transient_Scope (Desig) and then Nkind (Rel_Node) /= N_Simple_Return_Statement @@ -8757,7 +8756,7 @@ package body Exp_Util is return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N))); end if; - if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + if Nkind (N) in N_Indexed_Component | N_Selected_Component then if Is_Bit_Packed_Array (Etype (Prefix (N))) then Result := True; else @@ -8799,7 +8798,7 @@ package body Exp_Util is then return True; - elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then return Is_Ref_To_Bit_Packed_Slice (Prefix (N)); else @@ -8817,7 +8816,7 @@ package body Exp_Util is begin if Kind = N_Object_Renaming_Declaration then return True; - elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then + elsif Kind in N_Indexed_Component | N_Selected_Component then return Is_Renamed_Object (Pnod); else return False; @@ -8975,7 +8974,7 @@ package body Exp_Util is -- True if volatile component - elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then if (Is_Entity_Name (Prefix (N)) and then Has_Volatile_Components (Entity (Prefix (N)))) or else (Present (Etype (Prefix (N))) @@ -11004,7 +11003,7 @@ package body Exp_Util is => -- Check the "then statements" for elsif parts and if statements - if Nkind_In (N, N_Elsif_Part, N_If_Statement) + if Nkind (N) in N_Elsif_Part | N_If_Statement and then not Is_Empty_List (Then_Statements (N)) and then not Are_Wrapped (Then_Statements (N)) and then Requires_Cleanup_Actions @@ -11021,9 +11020,8 @@ package body Exp_Util is -- Check the "else statements" for conditional entry calls, if -- statements and selective accepts. - if Nkind_In (N, N_Conditional_Entry_Call, - N_If_Statement, - N_Selective_Accept) + if Nkind (N) in + N_Conditional_Entry_Call | N_If_Statement | N_Selective_Accept and then not Is_Empty_List (Else_Statements (N)) and then not Are_Wrapped (Else_Statements (N)) and then Requires_Cleanup_Actions @@ -11555,7 +11553,7 @@ package body Exp_Util is -- by the expression it renames, which would defeat the purpose of -- removing the side effect. - if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component) + if Nkind (Exp) in N_Selected_Component | N_Indexed_Component and then Has_Non_Standard_Rep (Etype (Prefix (Exp))) then null; @@ -11982,8 +11980,8 @@ package body Exp_Util is -- and view swaps, the parent type is taken from the formal -- parameter of the subprogram being called. - if Nkind_In (Context, N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (Context) in + N_Function_Call | N_Procedure_Call_Statement and then No (Type_Map.Get (Entity (Name (Context)))) then New_Ref := @@ -12149,9 +12147,8 @@ package body Exp_Util is Lib_Level : Boolean) return Boolean is At_Lib_Level : constant Boolean := - Lib_Level - and then Nkind_In (N, N_Package_Body, - N_Package_Specification); + Lib_Level + and then Nkind (N) in N_Package_Body | N_Package_Specification; -- N is at the library level if the top-most context is a package and -- the path taken to reach N does not include nonpackage constructs. @@ -12528,8 +12525,8 @@ package body Exp_Util is if (Nkind (Pexp) = N_Assignment_Statement and then Expression (Pexp) = Exp) - or else Nkind_In (Pexp, N_Object_Declaration, - N_Object_Renaming_Declaration) + or else Nkind (Pexp) + in N_Object_Declaration | N_Object_Renaming_Declaration then return True; @@ -12785,10 +12782,9 @@ package body Exp_Util is Set_Entity_Current_Value (Right_Opnd (Cond)); end if; - elsif Nkind_In (Cond, - N_Type_Conversion, - N_Qualified_Expression, - N_Expression_With_Actions) + elsif Nkind (Cond) in N_Type_Conversion + | N_Qualified_Expression + | N_Expression_With_Actions then Set_Expression_Current_Value (Expression (Cond)); @@ -12861,7 +12857,7 @@ package body Exp_Util is if Nkind (N) = N_Subprogram_Body and then Address_Taken (Spec_Id) and then - Ekind_In (Scope (Spec_Id), E_Block, E_Procedure, E_Function) + Ekind (Scope (Spec_Id)) in E_Block | E_Procedure | E_Function then declare Loc : constant Source_Ptr := Sloc (N); @@ -13085,7 +13081,7 @@ package body Exp_Util is elsif Is_Entity_Name (N) then return Ekind (Entity (N)) = E_In_Parameter; - elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then return Within_In_Parameter (Prefix (N)); else @@ -13166,9 +13162,7 @@ package body Exp_Util is -- explicit dereference, then the designated object could -- be modified by an assignment. - if Nkind_In (RO, N_Indexed_Component, - N_Explicit_Dereference) - then + if Nkind (RO) in N_Indexed_Component | N_Explicit_Dereference then return False; -- A selected component must have a safe prefix @@ -13697,8 +13691,7 @@ package body Exp_Util is Par := Parent (N); while Present (Par) loop - if Nkind_In (Original_Node (Par), N_Case_Expression, - N_If_Expression) + if Nkind (Original_Node (Par)) in N_Case_Expression | N_If_Expression then return True; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 463a89c..858a28a 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -192,6 +192,7 @@ extern Boolean In_Extended_Main_Code_Unit (Entity_Id); #define Ada_Version opt__ada_version #define Back_End_Inlining opt__back_end_inlining #define Debug_Generated_Code opt__debug_generated_code +#define Enable_128bit_Types opt__enable_128bit_types #define Exception_Extra_Info opt__exception_extra_info #define Exception_Locations_Suppressed opt__exception_locations_suppressed #define Exception_Mechanism opt__exception_mechanism @@ -212,6 +213,7 @@ typedef enum { extern Ada_Version_Type Ada_Version; extern Boolean Back_End_Inlining; extern Boolean Debug_Generated_Code; +extern Boolean Enable_128bit_Types; extern Boolean Exception_Extra_Info; extern Boolean Exception_Locations_Suppressed; extern Exception_Mechanism_Type Exception_Mechanism; @@ -280,10 +282,8 @@ extern Boolean Is_Derived_Type (Entity_Id); /* sem_eval: */ #define Compile_Time_Known_Value sem_eval__compile_time_known_value -#define Is_OK_Static_Expression sem_eval__is_ok_static_expression extern Boolean Compile_Time_Known_Value (Node_Id); -extern Boolean Is_OK_Static_Expression (Node_Id); /* sem_util: */ diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index b24e917..1c177b1 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -283,11 +283,11 @@ package body Freeze is and then (Present (Interface_Name (Renamed_Subp)) - or else Nam_In (Chars (Renamed_Subp), Name_Rotate_Left, - Name_Rotate_Right, - Name_Shift_Left, - Name_Shift_Right, - Name_Shift_Right_Arithmetic)) + or else Chars (Renamed_Subp) in Name_Rotate_Left + | Name_Rotate_Right + | Name_Shift_Left + | Name_Shift_Right + | Name_Shift_Right_Arithmetic) then Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); @@ -412,7 +412,7 @@ package body Freeze is -- as we need to check other conditions for creating a body to inline -- in that case, which are controlled in Analyze_Subprogram_Body_Helper. - if Ekind_In (Old_S, E_Function, E_Procedure) + if Ekind (Old_S) in E_Function | E_Procedure and then Nkind (Decl) = N_Subprogram_Declaration and then not Is_Generic_Instance (Old_S) and then not GNATprove_Mode @@ -1894,8 +1894,8 @@ package body Freeze is end if; elsif Ekind (E) in Task_Kind - and then Nkind_In (Parent (E), N_Single_Task_Declaration, - N_Task_Type_Declaration) + and then Nkind (Parent (E)) in + N_Single_Task_Declaration | N_Task_Type_Declaration then Push_Scope (E); Freeze_All (First_Entity (E), After); @@ -1986,15 +1986,15 @@ package body Freeze is -- current package, but this body does not freeze incomplete -- types that may be declared in this private part. - if (Nkind_In (Bod, N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) - or else Nkind (Bod) in N_Body_Stub) + if Comes_From_Source (Bod) + and then Nkind (Bod) in N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body + | N_Body_Stub and then List_Containing (After) = List_Containing (Parent (E)) - and then Comes_From_Source (Bod) then Error_Msg_Sloc := Sloc (Next (After)); Error_Msg_NE @@ -2373,8 +2373,7 @@ package body Freeze is begin case Nkind (N) is when N_Attribute_Reference => - if Nam_In (Attribute_Name (N), Name_Access, - Name_Unchecked_Access) + if Attribute_Name (N) in Name_Access | Name_Unchecked_Access and then Is_Entity_Name (Prefix (N)) and then Is_Type (Entity (Prefix (N))) and then Entity (Prefix (N)) = E @@ -3431,7 +3430,7 @@ package body Freeze is Check_Address_Clause (E); -- Similar processing is needed for aspects that may affect object - -- layout, like Alignment, if there is an initialization expression. + -- layout, like Address, if there is an initialization expression. -- We don't do this if there is a pragma Linker_Section, because it -- would prevent the back end from statically initializing the -- object; we don't want elaboration code in that case. @@ -3439,11 +3438,11 @@ package body Freeze is if Has_Delayed_Aspects (E) and then Expander_Active and then Is_Array_Type (Typ) - and then Present (Expression (Parent (E))) + and then Present (Expression (Declaration_Node (E))) and then No (Linker_Section_Pragma (E)) then declare - Decl : constant Node_Id := Parent (E); + Decl : constant Node_Id := Declaration_Node (E); Lhs : constant Node_Id := New_Occurrence_Of (E, Loc); begin @@ -4140,7 +4139,7 @@ package body Freeze is -- Handle the component and discriminant case - if Ekind_In (Comp, E_Component, E_Discriminant) then + if Ekind (Comp) in E_Component | E_Discriminant then declare CC : constant Node_Id := Component_Clause (Comp); @@ -5203,7 +5202,7 @@ package body Freeze is -- case, both the body and imported function utilize the same -- type. - if Ekind_In (E, E_Function, E_Generic_Function) then + if Ekind (E) in E_Function | E_Generic_Function then Stmt := Make_Simple_Return_Statement (Loc, Expression => @@ -5573,10 +5572,9 @@ package body Freeze is begin while Present (Prag) loop - if Nam_In (Pragma_Name_Unmapped (Prag), - Name_Post, - Name_Postcondition, - Name_Refined_Post) + if Pragma_Name_Unmapped (Prag) in Name_Post + | Name_Postcondition + | Name_Refined_Post then Exp := Expression @@ -5673,7 +5671,7 @@ package body Freeze is -- Remaining step is to layout objects - if Ekind_In (E, E_Variable, E_Constant, E_Loop_Parameter) + if Ekind (E) in E_Variable | E_Constant | E_Loop_Parameter or else Is_Formal (E) then Layout_Object (E); @@ -5684,7 +5682,7 @@ package body Freeze is -- statement, move them back now directly within the enclosing -- statement sequence. - if Ekind_In (E, E_Constant, E_Variable) + if Ekind (E) in E_Constant | E_Variable and then not Has_Delayed_Freeze (E) then Explode_Initialization_Compound_Statement (E); @@ -6045,7 +6043,7 @@ package body Freeze is -- for the case of a private type with record extension (we will do -- that later when the full type is frozen). - elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then + elsif Ekind (E) in E_Record_Type | E_Record_Subtype then if not In_Generic_Scope (E) then Freeze_Record_Type (E); end if; @@ -6625,9 +6623,9 @@ package body Freeze is begin pragma Assert - (Nam_In (Op_Name, Name_Allocate, - Name_Deallocate, - Name_Storage_Size)); + (Op_Name in Name_Allocate + | Name_Deallocate + | Name_Storage_Size); Error_Msg_Name_1 := Op_Name; @@ -6639,7 +6637,7 @@ package body Freeze is Op := Get_Name_Entity_Id (Op_Name); while Present (Op) loop - if Ekind_In (Op, E_Function, E_Procedure) + if Ekind (Op) in E_Function | E_Procedure and then Scope (Op) = Current_Scope then Formal := First_Entity (Op); @@ -6770,7 +6768,7 @@ package body Freeze is Check_Strict_Alignment (E); end if; - if Ekind_In (E, E_Record_Type, E_Record_Subtype) then + if Ekind (E) in E_Record_Type | E_Record_Subtype then declare RC : constant Node_Id := Get_Record_Representation_Clause (E); begin @@ -7499,7 +7497,7 @@ package body Freeze is -- The case we are looking for is an enumeration literal - if Nkind_In (N, N_Identifier, N_Character_Literal) + if Nkind (N) in N_Identifier | N_Character_Literal and then Is_Enumeration_Type (Etype (N)) then -- If enumeration literal appears directly as the choice, @@ -7874,8 +7872,8 @@ package body Freeze is function Clone_Id (Node : Node_Id) return Traverse_Result is begin - if Nkind_In (Node, N_Iterator_Specification, - N_Loop_Parameter_Specification) + if Nkind (Node) in + N_Iterator_Specification | N_Loop_Parameter_Specification then Set_Defining_Identifier (Node, New_Copy (Defining_Identifier (Node))); @@ -7966,7 +7964,7 @@ package body Freeze is -- Check that the enclosing record type can be frozen - if Ekind_In (Entity (Node), E_Component, E_Discriminant) then + if Ekind (Entity (Node)) in E_Component | E_Discriminant then Check_And_Freeze_Type (Scope (Entity (Node))); end if; @@ -8833,7 +8831,7 @@ package body Freeze is -- Check attribute Extra_Accessibility_Of_Result - if Ekind_In (E, E_Function, E_Subprogram_Type) + if Ekind (E) in E_Function | E_Subprogram_Type and then Needs_Result_Accessibility_Level (E) and then No (Extra_Accessibility_Of_Result (E)) then @@ -9234,11 +9232,11 @@ package body Freeze is -- directly. if Nkind (Dcopy) = N_Identifier - or else Nkind_In (Dcopy, N_Expanded_Name, - N_Integer_Literal, - N_Character_Literal, - N_String_Literal, - N_Real_Literal) + or else Nkind (Dcopy) in N_Expanded_Name + | N_Integer_Literal + | N_Character_Literal + | N_String_Literal + | N_Real_Literal or else (Nkind (Dcopy) = N_Attribute_Reference and then Attribute_Name (Dcopy) = Name_Null_Parameter) or else Known_Null (Dcopy) diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 0fd3424..b194741 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -382,6 +382,16 @@ begin Warn_On_Non_Local_Exception := True; end if; + -- Disable Initialize_Scalars for runtime files to avoid circular + -- dependencies. + + if Initialize_Scalars + and then Fname.Is_Predefined_File_Name (File_Name (Main_Source_File)) + then + Initialize_Scalars := False; + Init_Or_Norm_Scalars := Normalize_Scalars; + end if; + -- Now on to the semantics. Skip if in syntax only mode if Operating_Mode /= Check_Syntax then diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 025714b..cd0a50b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -232,7 +232,7 @@ static tree build_position_list (tree, bool, tree, tree, unsigned int, tree); static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool); static vec<variant_desc> build_variant_list (tree, Node_Id, vec<subst_pair>, vec<variant_desc>); -static tree maybe_saturate_size (tree); +static tree maybe_saturate_size (tree, unsigned int align); static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool, const char *, const char *); static void set_rm_size (Uint, tree, Entity_Id); @@ -524,7 +524,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) else if (IN (kind, Access_Kind)) max_esize = POINTER_SIZE * 2; else - max_esize = LONG_LONG_TYPE_SIZE; + max_esize = Enable_128bit_Types ? 128 : LONG_LONG_TYPE_SIZE; if (esize > max_esize) esize = max_esize; @@ -1245,6 +1245,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR && TREE_OPERAND (gnu_address, 1) == off) gnu_address = TREE_OPERAND (gnu_address, 0); + /* This is the pattern built for an overaligned object. */ else if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR && TREE_CODE (TREE_OPERAND (gnu_address, 1)) @@ -1255,6 +1256,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = build2 (POINTER_PLUS_EXPR, gnu_type, TREE_OPERAND (gnu_address, 0), TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 0)); + + /* We make an exception for an absolute address but we warn + that there is a descriptor at the start of the object. */ + else if (TREE_CODE (gnu_address) == INTEGER_CST) + { + post_error_ne ("??aliased object& with unconstrained " + "array nominal subtype", gnat_clause, + gnat_entity); + post_error ("\\starts with a descriptor whose size is " + "given by ''Descriptor_Size", gnat_clause); + } + else { post_error_ne ("aliased object& with unconstrained array " @@ -2480,8 +2493,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type); tree gnu_min, gnu_max, gnu_high; - /* We try to define subtypes for discriminants used as bounds - that are more restrictive than those declared by using the + /* We try to create subtypes for discriminants used as bounds + that are more restrictive than those declared, by using the bounds of the index type of the base array type. This will make it possible to calculate the maximum size of the record type more conservatively. This may have already been done by @@ -2489,8 +2502,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) there will be a conversion that needs to be removed first. */ if (CONTAINS_PLACEHOLDER_P (gnu_orig_min) && TYPE_RM_SIZE (gnu_base_index_type) - && !tree_int_cst_lt (TYPE_RM_SIZE (gnu_index_type), - TYPE_RM_SIZE (gnu_base_index_type))) + && tree_int_cst_lt (TYPE_RM_SIZE (gnu_base_index_type), + TYPE_RM_SIZE (gnu_index_type))) { gnu_orig_min = remove_conversions (gnu_orig_min, false); TREE_TYPE (gnu_orig_min) @@ -2501,8 +2514,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (CONTAINS_PLACEHOLDER_P (gnu_orig_max) && TYPE_RM_SIZE (gnu_base_index_type) - && !tree_int_cst_lt (TYPE_RM_SIZE (gnu_index_type), - TYPE_RM_SIZE (gnu_base_index_type))) + && tree_int_cst_lt (TYPE_RM_SIZE (gnu_base_index_type), + TYPE_RM_SIZE (gnu_index_type))) { gnu_orig_max = remove_conversions (gnu_orig_max, false); TREE_TYPE (gnu_orig_max) @@ -4412,7 +4425,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If the size is self-referential, annotate the maximum value after saturating it, if need be, to avoid a No_Uint value. */ if (CONTAINS_PLACEHOLDER_P (gnu_size)) - gnu_size = maybe_saturate_size (max_size (gnu_size, true)); + { + const unsigned int align + = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT; + gnu_size + = maybe_saturate_size (max_size (gnu_size, true), align); + } /* If we are just annotating types and the type is tagged, the tag and the parent components are not generated by the front-end so @@ -4448,7 +4466,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_size = size_binop (PLUS_EXPR, gnu_size, offset); } - gnu_size = maybe_saturate_size (round_up (gnu_size, align)); + gnu_size + = maybe_saturate_size (round_up (gnu_size, align), align); Set_Esize (gnat_entity, annotate_value (gnu_size)); /* Tagged types are Strict_Alignment so RM_Size = Esize. */ @@ -8849,11 +8868,15 @@ build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition) if (!Is_Access_Type (Etype (Node (gnat_constr)))) { tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim); - tree replacement = convert (TREE_TYPE (gnu_field), - elaborate_expression - (Node (gnat_constr), gnat_subtype, - get_entity_char (gnat_discrim), - definition, true, false)); + tree replacement + = elaborate_expression (Node (gnat_constr), gnat_subtype, + get_entity_char (gnat_discrim), + definition, true, false); + /* If this is a definition, we need to make sure that the SAVE_EXPRs + are instantiated on every possibly path in size computations. */ + if (definition && TREE_CODE (replacement) == SAVE_EXPR) + add_stmt (replacement); + replacement = convert (TREE_TYPE (gnu_field), replacement); subst_pair s = { gnu_field, replacement }; gnu_list.safe_push (s); } @@ -8929,15 +8952,21 @@ build_variant_list (tree gnu_qual_union_type, Node_Id gnat_variant_part, } /* If SIZE has overflowed, return the maximum valid size, which is the upper - bound of the signed sizetype in bits; otherwise return SIZE unmodified. */ + bound of the signed sizetype in bits, rounded down to ALIGN. Otherwise + return SIZE unmodified. */ static tree -maybe_saturate_size (tree size) +maybe_saturate_size (tree size, unsigned int align) { if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) - size = size_binop (MULT_EXPR, - fold_convert (bitsizetype, TYPE_MAX_VALUE (ssizetype)), - build_int_cst (bitsizetype, BITS_PER_UNIT)); + { + size + = size_binop (MULT_EXPR, + fold_convert (bitsizetype, TYPE_MAX_VALUE (ssizetype)), + build_int_cst (bitsizetype, BITS_PER_UNIT)); + size = round_down (size, align); + } + return size; } @@ -9079,10 +9108,12 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity) if (uint_size == No_Uint) return; - /* Only issue an error if a Value_Size clause was explicitly given. - Otherwise, we'd be duplicating an error on the Size clause. */ + /* Only issue an error if a Value_Size clause was explicitly given for the + entity; otherwise, we'd be duplicating an error on the Size clause. */ gnat_attr_node = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size); + if (Present (gnat_attr_node) && Entity (gnat_attr_node) != gnat_entity) + gnat_attr_node = Empty; /* Get the size as an INTEGER_CST. Issue an error if a size was specified but cannot be represented in bitsizetype. */ diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index e43b3db..355178e 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -390,6 +390,9 @@ enum standard_datatypes /* Function decl node for 64-bit multiplication with overflow checking. */ ADT_mulv64_decl, + /* Function decl node for 128-bit multiplication with overflow checking. */ + ADT_mulv128_decl, + /* Identifier for the name of the _Parent field in tagged record types. */ ADT_parent_name_id, @@ -462,6 +465,7 @@ extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1]; #define free_decl gnat_std_decls[(int) ADT_free_decl] #define realloc_decl gnat_std_decls[(int) ADT_realloc_decl] #define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl] +#define mulv128_decl gnat_std_decls[(int) ADT_mulv128_decl] #define parent_name_id gnat_std_decls[(int) ADT_parent_name_id] #define exception_data_name_id gnat_std_decls[(int) ADT_exception_data_name_id] #define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type] @@ -1035,6 +1039,7 @@ extern Pos get_target_short_size (void); extern Pos get_target_int_size (void); extern Pos get_target_long_size (void); extern Pos get_target_long_long_size (void); +extern Pos get_target_long_long_long_size (void); extern Pos get_target_pointer_size (void); extern Pos get_target_maximum_default_alignment (void); extern Pos get_target_system_allocator_alignment (void); diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 3999f9c..781868e 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -35,6 +35,7 @@ #include "stor-layout.h" #include "print-tree.h" #include "toplev.h" +#include "tree-pass.h" #include "langhooks.h" #include "langhooks-def.h" #include "plugin.h" @@ -307,6 +308,9 @@ internal_error_function (diagnostic_context *context, const char *msgid, /* Warn if plugins present. */ warn_if_plugins (); + /* Dump the representation of the function. */ + emergency_dump_function (); + /* Reset the pretty-printer. */ pp_clear_output_area (context->printer); @@ -614,10 +618,9 @@ gnat_get_fixed_point_type_info (const_tree type, { tree scale_factor; - /* GDB cannot handle fixed-point types yet, so rely on GNAT encodings - instead for it. */ + /* Do nothing if the GNAT encodings are used. */ if (!TYPE_IS_FIXED_POINT_P (type) - || gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + || gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) return false; scale_factor = TYPE_SCALE_FACTOR (type); @@ -1000,6 +1003,10 @@ get_array_bit_stride (tree comp_type) if (INTEGRAL_TYPE_P (comp_type)) return TYPE_RM_SIZE (comp_type); + /* Likewise for record or union types. */ + if (RECORD_OR_UNION_TYPE_P (comp_type) && !TYPE_FAT_POINTER_P (comp_type)) + return TYPE_ADA_SIZE (comp_type); + /* The gnat_get_array_descr_info debug hook expects a debug tyoe. */ comp_type = maybe_debug_type (comp_type); diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c index 9b2d241..60a37e1 100644 --- a/gcc/ada/gcc-interface/targtyps.c +++ b/gcc/ada/gcc-interface/targtyps.c @@ -29,6 +29,7 @@ #include "system.h" #include "coretypes.h" #include "tm.h" +#include "target.h" #include "tree.h" #include "ada.h" @@ -95,6 +96,15 @@ get_target_long_long_size (void) } Pos +get_target_long_long_long_size (void) +{ + if (targetm.scalar_mode_supported_p (TImode)) + return GET_MODE_BITSIZE (TImode); + else + return LONG_LONG_TYPE_SIZE; +} + +Pos get_target_pointer_size (void) { return POINTER_SIZE; diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index f74e0e7..f03d591 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -439,6 +439,19 @@ gigi (Node_Id gnat_root, NULL_TREE, is_default, true, true, true, false, false, NULL, Empty); + if (Enable_128bit_Types) + { + tree int128_type = gnat_type_for_size (128, 0); + mulv128_decl + = create_subprog_decl (get_identifier ("__gnat_mulv128"), NULL_TREE, + build_function_type_list (int128_type, + int128_type, + int128_type, + NULL_TREE), + NULL_TREE, is_default, true, true, true, false, + false, NULL, Empty); + } + /* Name of the _Parent field in tagged record types. */ parent_name_id = get_identifier (Get_Name_String (Name_uParent)); @@ -624,7 +637,7 @@ gigi (Node_Id gnat_root, constructor_elt *elt; fdesc_type_node = make_node (RECORD_TYPE); - vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS); + vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS, true); elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1); for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++) @@ -678,7 +691,8 @@ gigi (Node_Id gnat_root, /* Save the current optimization options again after the above possible global_options changes. */ - optimization_default_node = build_optimization_node (&global_options); + optimization_default_node + = build_optimization_node (&global_options, &global_options_set); optimization_current_node = optimization_default_node; /* Now translate the compilation unit proper. */ @@ -968,12 +982,8 @@ lvalue_for_aggregate_p (Node_Id gnat_node, tree gnu_type) get_unpadded_type (Etype (gnat_parent))); case N_Object_Declaration: - /* For an aggregate object declaration, return the constant at top level - in order to avoid generating elaboration code. */ - if (global_bindings_p ()) - return false; - - /* ... fall through ... */ + /* For an aggregate object declaration, return false consistently. */ + return false; case N_Assignment_Statement: /* For an aggregate assignment, decide based on the size. */ @@ -1747,7 +1757,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result); } - vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS); + vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS, true); elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1); for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0; i < TARGET_VTABLE_USES_DESCRIPTORS; @@ -4007,6 +4017,11 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_poplevel (); gnu_result = end_stmt_group (); + /* Attempt setting the end_locus of our GCC body tree, typically a BIND_EXPR, + then the end_locus of our GCC subprogram declaration tree. */ + set_end_locus_from_node (gnu_result, gnat_node); + set_end_locus_from_node (gnu_subprog_decl, gnat_node); + /* If we populated the parameter attributes cache, we need to make sure that the cached expressions are evaluated on all the possible paths leading to their uses. So we force their evaluation on entry of the function. */ @@ -4101,12 +4116,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnu_return_label_stack->pop (); - /* Attempt setting the end_locus of our GCC body tree, typically a - BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram - declaration tree. */ - set_end_locus_from_node (gnu_result, gnat_node); - set_end_locus_from_node (gnu_subprog_decl, gnat_node); - /* On SEH targets, install an exception handler around the main entry point to catch unhandled exceptions. */ if (DECL_NAME (gnu_subprog_decl) == main_identifier_node @@ -6476,6 +6485,7 @@ gnat_to_gnu (Node_Id gnat_node) gnu_expr = gnat_to_gnu (Expression (gnat_node)); + /* First deal with erroneous expressions. */ if (TREE_CODE (gnu_expr) == ERROR_MARK) { /* If this is a named number for which we cannot manipulate @@ -6485,6 +6495,11 @@ gnat_to_gnu (Node_Id gnat_node) else if (type_annotate_only) gnu_expr = NULL_TREE; } + + /* Then a special case: we do not want the SLOC of the expression + of the tag to pop up every time it is referenced somewhere. */ + else if (EXPR_P (gnu_expr) && Is_Tag (gnat_temp)) + SET_EXPR_LOCATION (gnu_expr, UNKNOWN_LOCATION); } else gnu_expr = NULL_TREE; @@ -9386,6 +9401,15 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, convert (int64, rhs))); } + /* Likewise for a 128-bit mult and a 64-bit target. */ + else if (code == MULT_EXPR && precision == 128 && BITS_PER_WORD < 128) + { + tree int128 = gnat_type_for_size (128, 0); + return convert (gnu_type, build_call_n_expr (mulv128_decl, 2, + convert (int128, lhs), + convert (int128, rhs))); + } + enum internal_fn icode; switch (code) diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index a96fde6..048a0cf 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -1343,7 +1343,7 @@ make_type_from_size (tree type, tree size_tree, bool for_biased) not already have the proper size and the size is not too large. */ if (BIT_PACKED_ARRAY_TYPE_P (type) || (TYPE_PRECISION (type) == size && biased_p == for_biased) - || size > LONG_LONG_TYPE_SIZE) + || size > (Enable_128bit_Types ? 128 : LONG_LONG_TYPE_SIZE)) break; biased_p |= for_biased; @@ -2905,6 +2905,31 @@ aggregate_type_contains_array_p (tree type, bool self_referential) } } +/* Return true if TYPE is a type with variable size or a padding type with a + field of variable size or a record that has a field with such a type. */ + +static bool +type_has_variable_size (tree type) +{ + tree field; + + if (!TREE_CONSTANT (TYPE_SIZE (type))) + return true; + + if (TYPE_IS_PADDING_P (type) + && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type)))) + return true; + + if (!RECORD_OR_UNION_TYPE_P (type)) + return false; + + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + if (type_has_variable_size (TREE_TYPE (field))) + return true; + + return false; +} + /* Return a FIELD_DECL node. NAME is the field's name, TYPE is its type and RECORD_TYPE is the type of the enclosing record. If SIZE is nonzero, it is the specified size of the field. If POS is nonzero, it is the bit @@ -2974,13 +2999,15 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos, DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed; - /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a - byte boundary since GCC cannot handle less-aligned BLKmode bitfields. + /* If FIELD_TYPE has BLKmode, we must ensure this is aligned to at least + a byte boundary since GCC cannot handle less aligned BLKmode bitfields. + Likewise if it has a variable size and no specified position because + variable-sized objects need to be aligned to at least a byte boundary. Likewise for an aggregate without specified position that contains an - array, because in this case slices of variable length of this array - must be handled by GCC and variable-sized objects need to be aligned - to at least a byte boundary. */ + array because, in this case, slices of variable length of this array + must be handled by GCC and have variable size. */ if (packed && (TYPE_MODE (type) == BLKmode + || (!pos && type_has_variable_size (type)) || (!pos && AGGREGATE_TYPE_P (type) && aggregate_type_contains_array_p (type, false)))) diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 7f3cb66..54d52ba 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -370,12 +370,12 @@ package body Ghost is -- treated as Ghost when they contain a reference to a Ghost -- entity (SPARK RM 6.9(11)). - elsif Nam_In (Prag_Nam, Name_Global, - Name_Depends, - Name_Initializes, - Name_Refined_Global, - Name_Refined_Depends, - Name_Refined_State) + elsif Prag_Nam in Name_Global + | Name_Depends + | Name_Initializes + | Name_Refined_Global + | Name_Refined_Depends + | Name_Refined_State then return True; end if; @@ -1124,15 +1124,14 @@ package body Ghost is -- When the context is a [generic] package declaration, pragma Ghost -- resides in the visible declarations. - if Nkind_In (N, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (N) in N_Generic_Package_Declaration | N_Package_Declaration then Decl := First (Visible_Declarations (Specification (N))); -- When the context is a package or a subprogram body, pragma Ghost -- resides in the declarative part. - elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then + elsif Nkind (N) in N_Package_Body | N_Subprogram_Body then Decl := First (Declarations (N)); -- Otherwise pragma Ghost appears in the declarations following N @@ -1363,15 +1362,15 @@ package body Ghost is -- A child package or subprogram declaration becomes Ghost when its -- parent is Ghost (SPARK RM 6.9(2)). - elsif Nkind_In (N, N_Generic_Function_Renaming_Declaration, - N_Generic_Package_Declaration, - N_Generic_Package_Renaming_Declaration, - N_Generic_Procedure_Renaming_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Package_Renaming_Declaration, - N_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + elsif Nkind (N) in N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Package_Renaming_Declaration + | N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration and then Present (Parent_Spec (N)) then Par_Id := Defining_Entity (Unit (Parent_Spec (N))); @@ -1569,14 +1568,14 @@ package body Ghost is -- ??? could extra formal parameters cause a Ghost leak? if Mark_Formals - and then Nkind_In (N, N_Abstract_Subprogram_Declaration, - N_Formal_Abstract_Subprogram_Declaration, - N_Formal_Concrete_Subprogram_Declaration, - N_Generic_Subprogram_Declaration, - N_Subprogram_Body, - N_Subprogram_Body_Stub, - N_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + and then Nkind (N) in N_Abstract_Subprogram_Declaration + | N_Formal_Abstract_Subprogram_Declaration + | N_Formal_Concrete_Subprogram_Declaration + | N_Generic_Subprogram_Declaration + | N_Subprogram_Body + | N_Subprogram_Body_Stub + | N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration then Param := First (Parameter_Specifications (Specification (N))); while Present (Param) loop @@ -1659,7 +1658,7 @@ package body Ghost is -- subject to any Ghost annotation. else - pragma Assert (Nam_In (Mode, Name_Disable, Name_None, No_Name)); + pragma Assert (Mode in Name_Disable | Name_None | No_Name); return None; end if; end Name_To_Ghost_Mode; @@ -1678,20 +1677,20 @@ package body Ghost is if Is_Body (N) or else Is_Declaration (N) or else Nkind (N) in N_Generic_Instantiation - or else Nkind (N) in N_Push_Pop_xxx_Label - or else Nkind (N) in N_Raise_xxx_Error - or else Nkind (N) in N_Representation_Clause - or else Nkind (N) in N_Statement_Other_Than_Procedure_Call - or else Nkind_In (N, N_Call_Marker, - N_Freeze_Entity, - N_Freeze_Generic_Entity, - N_Itype_Reference, - N_Pragma, - N_Procedure_Call_Statement, - N_Use_Package_Clause, - N_Use_Type_Clause, - N_Variable_Reference_Marker, - N_With_Clause) + | N_Push_Pop_xxx_Label + | N_Raise_xxx_Error + | N_Representation_Clause + | N_Statement_Other_Than_Procedure_Call + | N_Call_Marker + | N_Freeze_Entity + | N_Freeze_Generic_Entity + | N_Itype_Reference + | N_Pragma + | N_Procedure_Call_Statement + | N_Use_Package_Clause + | N_Use_Type_Clause + | N_Variable_Reference_Marker + | N_With_Clause then -- Only ignored Ghost nodes must be recorded in the table @@ -1815,7 +1814,7 @@ package body Ghost is -- The Ghost mode of a [generic] freeze node depends on the Ghost mode -- of the entity being frozen. - elsif Nkind_In (N, N_Freeze_Entity, N_Freeze_Generic_Entity) then + elsif Nkind (N) in N_Freeze_Entity | N_Freeze_Generic_Entity then Set_Ghost_Mode_From_Entity (Entity (N)); -- The Ghost mode of a pragma depends on the associated entity. The diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 365ddd0..a9f48ce 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1346,8 +1346,7 @@ begin -- We can generate code for a package declaration or a subprogram -- declaration only if it does not required a body. - elsif Nkind_In (Main_Unit_Kind, N_Package_Declaration, - N_Subprogram_Declaration) + elsif Main_Unit_Kind in N_Package_Declaration | N_Subprogram_Declaration and then (not Body_Required (Main_Unit_Node) or else Distribution_Stub_Mode = Generate_Caller_Stub_Body) @@ -1357,8 +1356,8 @@ begin -- We can generate code for a generic package declaration of a generic -- subprogram declaration only if does not require a body. - elsif Nkind_In (Main_Unit_Kind, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration) + elsif Main_Unit_Kind in + N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration and then not Body_Required (Main_Unit_Node) then Back_End_Mode := Generate_Object; @@ -1366,8 +1365,8 @@ begin -- Compilation units that are renamings do not require bodies, so we can -- generate code for them. - elsif Nkind_In (Main_Unit_Kind, N_Package_Renaming_Declaration, - N_Subprogram_Renaming_Declaration) + elsif Main_Unit_Kind in N_Package_Renaming_Declaration | + N_Subprogram_Renaming_Declaration then Back_End_Mode := Generate_Object; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 0f6109e..882f9e2 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3610,18 +3610,38 @@ extension mode (the use of Off as a parameter cancels the effect of the @emph{-gnatX} command switch). In extension mode, the latest version of the Ada language is -implemented (currently Ada 2012), and in addition a small number +implemented (currently Ada 202x), and in addition a small number of GNAT specific extensions are recognized as follows: -@table @asis +@itemize * -@item @emph{Constrained attribute for generic objects} +@item +Constrained attribute for generic objects The @code{Constrained} attribute is permitted for objects of generic types. The result indicates if the corresponding actual is constrained. -@end table + +@item +@code{Static} aspect on intrinsic functions + +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. + +@item +@code{[]} aggregates + +This new aggregate syntax for arrays and containers is provided under -gnatX +to experiment and confirm this new language syntax. +@end itemize @node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{66}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{67} @@ -18572,7 +18592,7 @@ Value_Size Note: the entries marked '*' are not actually specified by the Ada Reference Manual, which has nothing to say about size in the dynamic -case. What GNAT does is to allocate sufficient bits to accomodate any +case. What GNAT does is to allocate sufficient bits to accommodate any possible dynamic values for the bounds at run-time. So far, so good, but GNAT has to obey the RM rules, so the question is diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index fc49da1..ab47192 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -85,15 +85,14 @@ About This Guide * What This Guide Contains:: * What You Should Know before Reading This Guide:: * Related Information:: -* A Note to Readers of Previous Versions of the Manual:: * Conventions:: Getting Started with GNAT +* System Requirements:: * Running GNAT:: * Running a Simple Ada Program:: * Running a Program with Multiple Units:: -* Using the gnatmake Utility:: The GNAT Compilation Model @@ -313,8 +312,6 @@ GNAT Utility Programs * The File Cleanup Utility gnatclean:: * The GNAT Library Browser gnatls:: -* The Cross-Referencing Tools gnatxref and gnatfind:: -* The Ada to HTML Converter gnathtml:: The File Cleanup Utility gnatclean @@ -327,25 +324,6 @@ The GNAT Library Browser gnatls * Switches for gnatls:: * Example of gnatls Usage:: -The Cross-Referencing Tools gnatxref and gnatfind - -* gnatxref Switches:: -* gnatfind Switches:: -* Configuration Files for gnatxref and gnatfind:: -* Regular Expressions in gnatfind and gnatxref:: -* Examples of gnatxref Usage:: -* Examples of gnatfind Usage:: - -Examples of gnatxref Usage - -* General Usage:: -* Using gnatxref with vi:: - -The Ada to HTML Converter gnathtml - -* Invoking gnathtml:: -* Installing gnathtml:: - GNAT and Program Execution * Running and Debugging Ada Programs:: @@ -571,19 +549,18 @@ toolset for the full Ada programming language. It documents the features of the compiler and tools, and explains how to use them to build Ada applications. -GNAT implements Ada 95, Ada 2005 and Ada 2012, and it may also be +GNAT implements Ada 95, Ada 2005, Ada 2012, and Ada 202x, and it may also be invoked in Ada 83 compatibility mode. By default, GNAT assumes Ada 2012, but you can override with a compiler switch (@ref{6,,Compiling Different Versions of Ada}) to explicitly specify the language version. Throughout this manual, references to 'Ada' without a year suffix -apply to all Ada 95/2005/2012 versions of the language. +apply to all Ada versions of the language, starting with Ada 95. @menu * What This Guide Contains:: * What You Should Know before Reading This Guide:: * Related Information:: -* A Note to Readers of Previous Versions of the Manual:: * Conventions:: @end menu @@ -656,12 +633,10 @@ in an Ada program. This guide assumes a basic familiarity with the Ada 95 language, as described in the International Standard ANSI/ISO/IEC-8652:1995, January 1995. -It does not require knowledge of the features introduced by Ada 2005 -or Ada 2012. Reference manuals for Ada 95, Ada 2005, and Ada 2012 are included in the GNAT documentation package. -@node Related Information,A Note to Readers of Previous Versions of the Manual,What You Should Know before Reading This Guide,About This Guide +@node Related Information,Conventions,What You Should Know before Reading This Guide,About This Guide @anchor{gnat_ugn/about_this_guide related-information}@anchor{12} @section Related Information @@ -699,145 +674,8 @@ for full information on the extensible editor and programming environment Emacs. @end itemize -@node A Note to Readers of Previous Versions of the Manual,Conventions,Related Information,About This Guide -@anchor{gnat_ugn/about_this_guide a-note-to-readers-of-previous-versions-of-the-manual}@anchor{13} -@section A Note to Readers of Previous Versions of the Manual - - -In early 2015 the GNAT manuals were transitioned to the -reStructuredText (rst) / Sphinx documentation generator technology. -During that process the @cite{GNAT User's Guide} was reorganized -so that related topics would be described together in the same chapter -or appendix. Here's a summary of the major changes realized in -the new document structure. - - -@itemize * - -@item -@ref{9,,The GNAT Compilation Model} has been extended so that it now covers -the following material: - - -@itemize - - -@item -The @code{gnatname}, @code{gnatkr}, and @code{gnatchop} tools - -@item -@ref{14,,Configuration Pragmas} - -@item -@ref{15,,GNAT and Libraries} - -@item -@ref{16,,Conditional Compilation} including @ref{17,,Preprocessing with gnatprep} -and @ref{18,,Integrated Preprocessing} - -@item -@ref{19,,Generating Ada Bindings for C and C++ headers} - -@item -@ref{1a,,Using GNAT Files with External Tools} -@end itemize - -@item -@ref{a,,Building Executable Programs with GNAT} is a new chapter consolidating -the following content: - - -@itemize - - -@item -@ref{1b,,Building with gnatmake} - -@item -@ref{1c,,Compiling with gcc} - -@item -@ref{1d,,Binding with gnatbind} - -@item -@ref{1e,,Linking with gnatlink} - -@item -@ref{1f,,Using the GNU make Utility} -@end itemize - -@item -@ref{b,,GNAT Utility Programs} is a new chapter consolidating the information about several -GNAT tools: - - - -@itemize - - -@item -@ref{20,,The File Cleanup Utility gnatclean} - -@item -@ref{21,,The GNAT Library Browser gnatls} - -@item -@ref{22,,The Cross-Referencing Tools gnatxref and gnatfind} - -@item -@ref{23,,The Ada to HTML Converter gnathtml} -@end itemize - -@item -@ref{c,,GNAT and Program Execution} is a new chapter consolidating the following: - - -@itemize - - -@item -@ref{24,,Running and Debugging Ada Programs} - -@item -@ref{25,,Profiling} - -@item -@ref{26,,Improving Performance} - -@item -@ref{27,,Overflow Check Handling in GNAT} - -@item -@ref{28,,Performing Dimensionality Analysis in GNAT} - -@item -@ref{29,,Stack Related Facilities} - -@item -@ref{2a,,Memory Management Issues} -@end itemize - -@item -@ref{d,,Platform-Specific Information} is a new appendix consolidating the following: - - -@itemize - - -@item -@ref{2b,,Run-Time Libraries} - -@item -@ref{2c,,Microsoft Windows Topics} - -@item -@ref{2d,,Mac OS Topics} -@end itemize - -@item -The @emph{Compatibility and Porting Guide} appendix has been moved to the -@cite{GNAT Reference Manual}. It now includes a section -@emph{Writing Portable Fixed-Point Declarations} which was previously -a separate chapter in the @cite{GNAT User's Guide}. -@end itemize - -@node Conventions,,A Note to Readers of Previous Versions of the Manual,About This Guide -@anchor{gnat_ugn/about_this_guide conventions}@anchor{2e} +@node Conventions,,Related Information,About This Guide +@anchor{gnat_ugn/about_this_guide conventions}@anchor{13} @section Conventions @@ -890,30 +728,59 @@ the '\' character should be used instead. @end itemize @node Getting Started with GNAT,The GNAT Compilation Model,About This Guide,Top -@anchor{gnat_ugn/getting_started_with_gnat getting-started-with-gnat}@anchor{8}@anchor{gnat_ugn/getting_started_with_gnat doc}@anchor{2f}@anchor{gnat_ugn/getting_started_with_gnat id1}@anchor{30} +@anchor{gnat_ugn/getting_started_with_gnat getting-started-with-gnat}@anchor{8}@anchor{gnat_ugn/getting_started_with_gnat doc}@anchor{14}@anchor{gnat_ugn/getting_started_with_gnat id1}@anchor{15} @chapter Getting Started with GNAT This chapter describes how to use GNAT's command line interface to build executable Ada programs. On most platforms a visually oriented Integrated Development Environment -is also available, the GNAT Programming Studio (GNAT Studio). +is also available: GNAT Studio. GNAT Studio offers a graphical "look and feel", support for development in other programming languages, comprehensive browsing features, and many other capabilities. -For information on GNAT Studio please refer to -@cite{Using the GNAT Programming Studio}. +For information on GNAT Studio please refer to the +@cite{GNAT Studio documentation}. @menu +* System Requirements:: * Running GNAT:: * Running a Simple Ada Program:: * Running a Program with Multiple Units:: -* Using the gnatmake Utility:: @end menu -@node Running GNAT,Running a Simple Ada Program,,Getting Started with GNAT -@anchor{gnat_ugn/getting_started_with_gnat running-gnat}@anchor{31}@anchor{gnat_ugn/getting_started_with_gnat id2}@anchor{32} +@node System Requirements,Running GNAT,,Getting Started with GNAT +@anchor{gnat_ugn/getting_started_with_gnat id2}@anchor{16}@anchor{gnat_ugn/getting_started_with_gnat system-requirements}@anchor{17} +@section System Requirements + + +Even though any machine can run the GNAT toolset and GNAT Studio IDE, in order +to get the best experience, we recommend using a machine with as many cores +as possible since all individual compilations can run in parallel. +A comfortable setup for a compiler server is a machine with 24 physical cores +or more, with at least 48 GB of memory (2 GB per core). + +For a desktop machine, a minimum of 4 cores is recommended (8 preferred), +with at least 2GB per core (so 8 to 16GB). + +In addition, for running and navigating sources in GNAT Studio smoothly, we +recommend at least 1.5 GB plus 3 GB of RAM per 1 million source line of code. +In other words, we recommend at least 3 GB for for 500K lines of code and +7.5 GB for 2 million lines of code. + +Note that using local and fast drives will also make a difference in terms of +build and link time. Network drives such as NFS, SMB, or worse, configuration +management filesystems (such as ClearCase dynamic views) should be avoided as +much as possible and will produce very degraded performance (typically 2 to 3 +times slower than on local fast drives). If such slow drives cannot be avoided +for accessing the source code, then you should at least configure your project +file so that the result of the compilation is stored on a drive local to the +machine performing the run. This can be achieved by setting the @code{Object_Dir} +project file attribute. + +@node Running GNAT,Running a Simple Ada Program,System Requirements,Getting Started with GNAT +@anchor{gnat_ugn/getting_started_with_gnat running-gnat}@anchor{18}@anchor{gnat_ugn/getting_started_with_gnat id3}@anchor{19} @section Running GNAT @@ -938,7 +805,7 @@ utility program that, given the name of the main program, automatically performs the necessary compilation, binding and linking steps. @node Running a Simple Ada Program,Running a Program with Multiple Units,Running GNAT,Getting Started with GNAT -@anchor{gnat_ugn/getting_started_with_gnat running-a-simple-ada-program}@anchor{33}@anchor{gnat_ugn/getting_started_with_gnat id3}@anchor{34} +@anchor{gnat_ugn/getting_started_with_gnat running-a-simple-ada-program}@anchor{1a}@anchor{gnat_ugn/getting_started_with_gnat id4}@anchor{1b} @section Running a Simple Ada Program @@ -967,12 +834,12 @@ extension is @code{ads} for a spec and @code{adb} for a body. You can override this default file naming convention by use of the special pragma @code{Source_File_Name} (for further information please -see @ref{35,,Using Other File Names}). +see @ref{1c,,Using Other File Names}). Alternatively, if you want to rename your files according to this default convention, which is probably more convenient if you will be using GNAT for all your compilations, then the @code{gnatchop} utility can be used to generate correctly-named source files -(see @ref{36,,Renaming Files with gnatchop}). +(see @ref{1d,,Renaming Files with gnatchop}). You can compile the program using the following command (@code{$} is used as the command prompt in the examples in this document): @@ -998,24 +865,12 @@ file corresponding to your Ada program. It also generates an 'Ada Library Information' file @code{hello.ali}, which contains additional information used to check that an Ada program is consistent. -To build an executable file, -use @code{gnatbind} to bind the program -and @code{gnatlink} to link it. The -argument to both @code{gnatbind} and @code{gnatlink} is the name of the -@code{ALI} file, but the default extension of @code{.ali} can -be omitted. This means that in the most common case, the argument -is simply the name of the main program: - -@example -$ gnatbind hello -$ gnatlink hello -@end example -A simpler method of carrying out these steps is to use @code{gnatmake}, -a master program that invokes all the required -compilation, binding and linking tools in the correct order. In particular, -@code{gnatmake} automatically recompiles any sources that have been -modified since they were last compiled, or sources that depend +To build an executable file, use either @code{gnatmake} or gprbuild with +the name of the main file: these tools are builders that will take care of +all the necessary build steps in the correct order. +In particular, these builders automatically recompile any sources that have +been modified since they were last compiled, or sources that depend on such modified sources, so that 'version skew' is avoided. @geindex Version skew (avoided by `@w{`}gnatmake`@w{`}) @@ -1042,8 +897,8 @@ Hello WORLD! appear in response to this command. -@node Running a Program with Multiple Units,Using the gnatmake Utility,Running a Simple Ada Program,Getting Started with GNAT -@anchor{gnat_ugn/getting_started_with_gnat id4}@anchor{37}@anchor{gnat_ugn/getting_started_with_gnat running-a-program-with-multiple-units}@anchor{38} +@node Running a Program with Multiple Units,,Running a Simple Ada Program,Getting Started with GNAT +@anchor{gnat_ugn/getting_started_with_gnat id5}@anchor{1e}@anchor{gnat_ugn/getting_started_with_gnat running-a-program-with-multiple-units}@anchor{1f} @section Running a Program with Multiple Units @@ -1096,17 +951,6 @@ body of package @code{Greetings} body of main program @end table -To build an executable version of -this program, we could use four separate steps to compile, bind, and link -the program, as follows: - -@example -$ gcc -c gmain.adb -$ gcc -c greetings.adb -$ gnatbind gmain -$ gnatlink gmain -@end example - Note that there is no required order of compilation when using GNAT. In particular it is perfectly fine to compile the main program first. Also, it is not necessary to compile package specs in the case where @@ -1118,74 +962,17 @@ generation, then use the @code{-gnatc} switch: $ gcc -c greetings.ads -gnatc @end example -Although the compilation can be done in separate steps as in the -above example, in practice it is almost always more convenient -to use the @code{gnatmake} tool. All you need to know in this case -is the name of the main program's source file. The effect of the above four -commands can be achieved with a single one: +Although the compilation can be done in separate steps, in practice it is +almost always more convenient to use the @code{gnatmake} or @code{gprbuild} tools: @example $ gnatmake gmain.adb @end example -In the next section we discuss the advantages of using @code{gnatmake} in -more detail. - -@node Using the gnatmake Utility,,Running a Program with Multiple Units,Getting Started with GNAT -@anchor{gnat_ugn/getting_started_with_gnat using-the-gnatmake-utility}@anchor{39}@anchor{gnat_ugn/getting_started_with_gnat id5}@anchor{3a} -@section Using the @code{gnatmake} Utility - - -If you work on a program by compiling single components at a time using -@code{gcc}, you typically keep track of the units you modify. In order to -build a consistent system, you compile not only these units, but also any -units that depend on the units you have modified. -For example, in the preceding case, -if you edit @code{gmain.adb}, you only need to recompile that file. But if -you edit @code{greetings.ads}, you must recompile both -@code{greetings.adb} and @code{gmain.adb}, because both files contain -units that depend on @code{greetings.ads}. - -@code{gnatbind} will warn you if you forget one of these compilation -steps, so that it is impossible to generate an inconsistent program as a -result of forgetting to do a compilation. Nevertheless it is tedious and -error-prone to keep track of dependencies among units. -One approach to handle the dependency-bookkeeping is to use a -makefile. However, makefiles present maintenance problems of their own: -if the dependencies change as you change the program, you must make -sure that the makefile is kept up-to-date manually, which is also an -error-prone process. - -The @code{gnatmake} utility takes care of these details automatically. -Invoke it using either one of the following forms: - -@example -$ gnatmake gmain.adb -$ gnatmake gmain -@end example - -The argument is the name of the file containing the main program; -you may omit the extension. @code{gnatmake} -examines the environment, automatically recompiles any files that need -recompiling, and binds and links the resulting set of object files, -generating the executable file, @code{gmain}. -In a large program, it -can be extremely helpful to use @code{gnatmake}, because working out by hand -what needs to be recompiled can be difficult. - -Note that @code{gnatmake} takes into account all the Ada rules that -establish dependencies among units. These include dependencies that result -from inlining subprogram bodies, and from -generic instantiation. Unlike some other -Ada make tools, @code{gnatmake} does not rely on the dependencies that were -found by the compiler on a previous compilation, which may possibly -be wrong when sources change. @code{gnatmake} determines the exact set of -dependencies from scratch each time it is run. - @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node The GNAT Compilation Model,Building Executable Programs with GNAT,Getting Started with GNAT,Top -@anchor{gnat_ugn/the_gnat_compilation_model doc}@anchor{3b}@anchor{gnat_ugn/the_gnat_compilation_model the-gnat-compilation-model}@anchor{9}@anchor{gnat_ugn/the_gnat_compilation_model id1}@anchor{3c} +@anchor{gnat_ugn/the_gnat_compilation_model doc}@anchor{20}@anchor{gnat_ugn/the_gnat_compilation_model the-gnat-compilation-model}@anchor{9}@anchor{gnat_ugn/the_gnat_compilation_model id1}@anchor{21} @chapter The GNAT Compilation Model @@ -1209,44 +996,44 @@ Topics related to source file makeup and naming @itemize * @item -@ref{3d,,Source Representation} +@ref{22,,Source Representation} @item -@ref{3e,,Foreign Language Representation} +@ref{23,,Foreign Language Representation} @item -@ref{3f,,File Naming Topics and Utilities} +@ref{24,,File Naming Topics and Utilities} @end itemize @item -@ref{14,,Configuration Pragmas} +@ref{25,,Configuration Pragmas} @item -@ref{40,,Generating Object Files} +@ref{26,,Generating Object Files} @item -@ref{41,,Source Dependencies} +@ref{27,,Source Dependencies} @item -@ref{42,,The Ada Library Information Files} +@ref{28,,The Ada Library Information Files} @item -@ref{43,,Binding an Ada Program} +@ref{29,,Binding an Ada Program} @item -@ref{15,,GNAT and Libraries} +@ref{2a,,GNAT and Libraries} @item -@ref{16,,Conditional Compilation} +@ref{2b,,Conditional Compilation} @item -@ref{44,,Mixed Language Programming} +@ref{2c,,Mixed Language Programming} @item -@ref{45,,GNAT and Other Compilation Models} +@ref{2d,,GNAT and Other Compilation Models} @item -@ref{1a,,Using GNAT Files with External Tools} +@ref{2e,,Using GNAT Files with External Tools} @end itemize @menu @@ -1267,7 +1054,7 @@ Topics related to source file makeup and naming @end menu @node Source Representation,Foreign Language Representation,,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model source-representation}@anchor{3d}@anchor{gnat_ugn/the_gnat_compilation_model id2}@anchor{46} +@anchor{gnat_ugn/the_gnat_compilation_model source-representation}@anchor{22}@anchor{gnat_ugn/the_gnat_compilation_model id2}@anchor{2f} @section Source Representation @@ -1282,7 +1069,7 @@ Topics related to source file makeup and naming Ada source programs are represented in standard text files, using Latin-1 coding. Latin-1 is an 8-bit code that includes the familiar 7-bit ASCII set, plus additional characters used for -representing foreign languages (see @ref{3e,,Foreign Language Representation} +representing foreign languages (see @ref{23,,Foreign Language Representation} for support of non-USA character sets). The format effector characters are represented using their standard ASCII encodings, as follows: @@ -1393,13 +1180,13 @@ compilation units) is represented using a sequence of files. Similarly, you will place each subunit or child unit in a separate file. @node Foreign Language Representation,File Naming Topics and Utilities,Source Representation,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model foreign-language-representation}@anchor{3e}@anchor{gnat_ugn/the_gnat_compilation_model id3}@anchor{47} +@anchor{gnat_ugn/the_gnat_compilation_model foreign-language-representation}@anchor{23}@anchor{gnat_ugn/the_gnat_compilation_model id3}@anchor{30} @section Foreign Language Representation GNAT supports the standard character sets defined in Ada as well as several other non-standard character sets for use in localized versions -of the compiler (@ref{48,,Character Set Control}). +of the compiler (@ref{31,,Character Set Control}). @menu * Latin-1:: @@ -1410,7 +1197,7 @@ of the compiler (@ref{48,,Character Set Control}). @end menu @node Latin-1,Other 8-Bit Codes,,Foreign Language Representation -@anchor{gnat_ugn/the_gnat_compilation_model id4}@anchor{49}@anchor{gnat_ugn/the_gnat_compilation_model latin-1}@anchor{4a} +@anchor{gnat_ugn/the_gnat_compilation_model id4}@anchor{32}@anchor{gnat_ugn/the_gnat_compilation_model latin-1}@anchor{33} @subsection Latin-1 @@ -1433,7 +1220,7 @@ string literals. In addition, the extended characters that represent letters can be used in identifiers. @node Other 8-Bit Codes,Wide_Character Encodings,Latin-1,Foreign Language Representation -@anchor{gnat_ugn/the_gnat_compilation_model other-8-bit-codes}@anchor{4b}@anchor{gnat_ugn/the_gnat_compilation_model id5}@anchor{4c} +@anchor{gnat_ugn/the_gnat_compilation_model other-8-bit-codes}@anchor{34}@anchor{gnat_ugn/the_gnat_compilation_model id5}@anchor{35} @subsection Other 8-Bit Codes @@ -1550,7 +1337,7 @@ the GNAT compiler sources. You will need to obtain a full source release of GNAT to obtain this file. @node Wide_Character Encodings,Wide_Wide_Character Encodings,Other 8-Bit Codes,Foreign Language Representation -@anchor{gnat_ugn/the_gnat_compilation_model id6}@anchor{4d}@anchor{gnat_ugn/the_gnat_compilation_model wide-character-encodings}@anchor{4e} +@anchor{gnat_ugn/the_gnat_compilation_model id6}@anchor{36}@anchor{gnat_ugn/the_gnat_compilation_model wide-character-encodings}@anchor{37} @subsection Wide_Character Encodings @@ -1661,7 +1448,7 @@ use of the upper half of the Latin-1 set. @end cartouche @node Wide_Wide_Character Encodings,,Wide_Character Encodings,Foreign Language Representation -@anchor{gnat_ugn/the_gnat_compilation_model id7}@anchor{4f}@anchor{gnat_ugn/the_gnat_compilation_model wide-wide-character-encodings}@anchor{50} +@anchor{gnat_ugn/the_gnat_compilation_model id7}@anchor{38}@anchor{gnat_ugn/the_gnat_compilation_model wide-wide-character-encodings}@anchor{39} @subsection Wide_Wide_Character Encodings @@ -1713,7 +1500,7 @@ ACATS (Ada Conformity Assessment Test Suite) test suite distributions. @end table @node File Naming Topics and Utilities,Configuration Pragmas,Foreign Language Representation,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model id8}@anchor{51}@anchor{gnat_ugn/the_gnat_compilation_model file-naming-topics-and-utilities}@anchor{3f} +@anchor{gnat_ugn/the_gnat_compilation_model id8}@anchor{3a}@anchor{gnat_ugn/the_gnat_compilation_model file-naming-topics-and-utilities}@anchor{24} @section File Naming Topics and Utilities @@ -1732,7 +1519,7 @@ source files correspond to the Ada compilation units that they contain. @end menu @node File Naming Rules,Using Other File Names,,File Naming Topics and Utilities -@anchor{gnat_ugn/the_gnat_compilation_model file-naming-rules}@anchor{52}@anchor{gnat_ugn/the_gnat_compilation_model id9}@anchor{53} +@anchor{gnat_ugn/the_gnat_compilation_model file-naming-rules}@anchor{3b}@anchor{gnat_ugn/the_gnat_compilation_model id9}@anchor{3c} @subsection File Naming Rules @@ -1841,7 +1628,7 @@ unit names are long (for example, if child units or subunits are heavily nested). An option is available to shorten such long file names (called file name 'krunching'). This may be particularly useful when programs being developed with GNAT are to be used on operating systems -with limited file name lengths. @ref{54,,Using gnatkr}. +with limited file name lengths. @ref{3d,,Using gnatkr}. Of course, no file shortening algorithm can guarantee uniqueness over all possible unit names; if file name krunching is used, it is your @@ -1850,7 +1637,7 @@ can specify the exact file names that you want used, as described in the next section. Finally, if your Ada programs are migrating from a compiler with a different naming convention, you can use the gnatchop utility to produce source files that follow the GNAT naming conventions. -(For details see @ref{36,,Renaming Files with gnatchop}.) +(For details see @ref{1d,,Renaming Files with gnatchop}.) Note: in the case of Windows or Mac OS operating systems, case is not significant. So for example on Windows if the canonical name is @@ -1860,7 +1647,7 @@ if you want to use other than canonically cased file names on a Unix system, you need to follow the procedures described in the next section. @node Using Other File Names,Alternative File Naming Schemes,File Naming Rules,File Naming Topics and Utilities -@anchor{gnat_ugn/the_gnat_compilation_model id10}@anchor{55}@anchor{gnat_ugn/the_gnat_compilation_model using-other-file-names}@anchor{35} +@anchor{gnat_ugn/the_gnat_compilation_model id10}@anchor{3e}@anchor{gnat_ugn/the_gnat_compilation_model using-other-file-names}@anchor{1c} @subsection Using Other File Names @@ -1898,7 +1685,7 @@ normally it will be placed in the @code{gnat.adc} file used to hold configuration pragmas that apply to a complete compilation environment. For more details on how the @code{gnat.adc} file is created and used -see @ref{56,,Handling of Configuration Pragmas}. +see @ref{3f,,Handling of Configuration Pragmas}. @geindex gnat.adc @@ -1920,7 +1707,7 @@ then it must be included in the @code{gnatmake} command, it may not be omitted. @node Alternative File Naming Schemes,Handling Arbitrary File Naming Conventions with gnatname,Using Other File Names,File Naming Topics and Utilities -@anchor{gnat_ugn/the_gnat_compilation_model id11}@anchor{57}@anchor{gnat_ugn/the_gnat_compilation_model alternative-file-naming-schemes}@anchor{58} +@anchor{gnat_ugn/the_gnat_compilation_model id11}@anchor{40}@anchor{gnat_ugn/the_gnat_compilation_model alternative-file-naming-schemes}@anchor{41} @subsection Alternative File Naming Schemes @@ -2064,7 +1851,7 @@ pragma Source_File_Name @geindex gnatname @node Handling Arbitrary File Naming Conventions with gnatname,File Name Krunching with gnatkr,Alternative File Naming Schemes,File Naming Topics and Utilities -@anchor{gnat_ugn/the_gnat_compilation_model handling-arbitrary-file-naming-conventions-with-gnatname}@anchor{59}@anchor{gnat_ugn/the_gnat_compilation_model id12}@anchor{5a} +@anchor{gnat_ugn/the_gnat_compilation_model handling-arbitrary-file-naming-conventions-with-gnatname}@anchor{42}@anchor{gnat_ugn/the_gnat_compilation_model id12}@anchor{43} @subsection Handling Arbitrary File Naming Conventions with @code{gnatname} @@ -2079,7 +1866,7 @@ pragma Source_File_Name @end menu @node Arbitrary File Naming Conventions,Running gnatname,,Handling Arbitrary File Naming Conventions with gnatname -@anchor{gnat_ugn/the_gnat_compilation_model arbitrary-file-naming-conventions}@anchor{5b}@anchor{gnat_ugn/the_gnat_compilation_model id13}@anchor{5c} +@anchor{gnat_ugn/the_gnat_compilation_model arbitrary-file-naming-conventions}@anchor{44}@anchor{gnat_ugn/the_gnat_compilation_model id13}@anchor{45} @subsubsection Arbitrary File Naming Conventions @@ -2090,11 +1877,11 @@ does not need additional information. When the source file names do not follow the standard GNAT default file naming conventions, the GNAT compiler must be given additional information through -a configuration pragmas file (@ref{14,,Configuration Pragmas}) +a configuration pragmas file (@ref{25,,Configuration Pragmas}) or a project file. When the non-standard file naming conventions are well-defined, a small number of pragmas @code{Source_File_Name} specifying a naming pattern -(@ref{58,,Alternative File Naming Schemes}) may be sufficient. However, +(@ref{41,,Alternative File Naming Schemes}) may be sufficient. However, if the file naming conventions are irregular or arbitrary, a number of pragma @code{Source_File_Name} for individual compilation units must be defined. @@ -2104,7 +1891,7 @@ GNAT provides a tool @code{gnatname} to generate the required pragmas for a set of files. @node Running gnatname,Switches for gnatname,Arbitrary File Naming Conventions,Handling Arbitrary File Naming Conventions with gnatname -@anchor{gnat_ugn/the_gnat_compilation_model running-gnatname}@anchor{5d}@anchor{gnat_ugn/the_gnat_compilation_model id14}@anchor{5e} +@anchor{gnat_ugn/the_gnat_compilation_model running-gnatname}@anchor{46}@anchor{gnat_ugn/the_gnat_compilation_model id14}@anchor{47} @subsubsection Running @code{gnatname} @@ -2155,7 +1942,7 @@ with pragmas @code{Source_File_Name} for each file that contains a valid Ada unit. @node Switches for gnatname,Examples of gnatname Usage,Running gnatname,Handling Arbitrary File Naming Conventions with gnatname -@anchor{gnat_ugn/the_gnat_compilation_model id15}@anchor{5f}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatname}@anchor{60} +@anchor{gnat_ugn/the_gnat_compilation_model id15}@anchor{48}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatname}@anchor{49} @subsubsection Switches for @code{gnatname} @@ -2338,7 +2125,7 @@ except those whose names end with @code{_nt.ada}. @end table @node Examples of gnatname Usage,,Switches for gnatname,Handling Arbitrary File Naming Conventions with gnatname -@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatname-usage}@anchor{61}@anchor{gnat_ugn/the_gnat_compilation_model id16}@anchor{62} +@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatname-usage}@anchor{4a}@anchor{gnat_ugn/the_gnat_compilation_model id16}@anchor{4b} @subsubsection Examples of @code{gnatname} Usage @@ -2364,7 +2151,7 @@ even in conjunction with one or several switches are used in this example. @node File Name Krunching with gnatkr,Renaming Files with gnatchop,Handling Arbitrary File Naming Conventions with gnatname,File Naming Topics and Utilities -@anchor{gnat_ugn/the_gnat_compilation_model file-name-krunching-with-gnatkr}@anchor{63}@anchor{gnat_ugn/the_gnat_compilation_model id17}@anchor{64} +@anchor{gnat_ugn/the_gnat_compilation_model file-name-krunching-with-gnatkr}@anchor{4c}@anchor{gnat_ugn/the_gnat_compilation_model id17}@anchor{4d} @subsection File Name Krunching with @code{gnatkr} @@ -2385,7 +2172,7 @@ applying this shortening. @end menu @node About gnatkr,Using gnatkr,,File Name Krunching with gnatkr -@anchor{gnat_ugn/the_gnat_compilation_model id18}@anchor{65}@anchor{gnat_ugn/the_gnat_compilation_model about-gnatkr}@anchor{66} +@anchor{gnat_ugn/the_gnat_compilation_model id18}@anchor{4e}@anchor{gnat_ugn/the_gnat_compilation_model about-gnatkr}@anchor{4f} @subsubsection About @code{gnatkr} @@ -2423,7 +2210,7 @@ The @code{gnatkr} utility can be used to determine the krunched name for a given file, when krunched to a specified maximum length. @node Using gnatkr,Krunching Method,About gnatkr,File Name Krunching with gnatkr -@anchor{gnat_ugn/the_gnat_compilation_model id19}@anchor{67}@anchor{gnat_ugn/the_gnat_compilation_model using-gnatkr}@anchor{54} +@anchor{gnat_ugn/the_gnat_compilation_model id19}@anchor{50}@anchor{gnat_ugn/the_gnat_compilation_model using-gnatkr}@anchor{3d} @subsubsection Using @code{gnatkr} @@ -2460,7 +2247,7 @@ The output is the krunched name. The output has an extension only if the original argument was a file name with an extension. @node Krunching Method,Examples of gnatkr Usage,Using gnatkr,File Name Krunching with gnatkr -@anchor{gnat_ugn/the_gnat_compilation_model id20}@anchor{68}@anchor{gnat_ugn/the_gnat_compilation_model krunching-method}@anchor{69} +@anchor{gnat_ugn/the_gnat_compilation_model id20}@anchor{51}@anchor{gnat_ugn/the_gnat_compilation_model krunching-method}@anchor{52} @subsubsection Krunching Method @@ -2590,7 +2377,7 @@ program @code{gnatkr} is supplied for conveniently determining the krunched name of a file. @node Examples of gnatkr Usage,,Krunching Method,File Name Krunching with gnatkr -@anchor{gnat_ugn/the_gnat_compilation_model id21}@anchor{6a}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatkr-usage}@anchor{6b} +@anchor{gnat_ugn/the_gnat_compilation_model id21}@anchor{53}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatkr-usage}@anchor{54} @subsubsection Examples of @code{gnatkr} Usage @@ -2604,7 +2391,7 @@ $ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads @end example @node Renaming Files with gnatchop,,File Name Krunching with gnatkr,File Naming Topics and Utilities -@anchor{gnat_ugn/the_gnat_compilation_model id22}@anchor{6c}@anchor{gnat_ugn/the_gnat_compilation_model renaming-files-with-gnatchop}@anchor{36} +@anchor{gnat_ugn/the_gnat_compilation_model id22}@anchor{55}@anchor{gnat_ugn/the_gnat_compilation_model renaming-files-with-gnatchop}@anchor{1d} @subsection Renaming Files with @code{gnatchop} @@ -2624,7 +2411,7 @@ files to meet the standard GNAT default file naming conventions. @end menu @node Handling Files with Multiple Units,Operating gnatchop in Compilation Mode,,Renaming Files with gnatchop -@anchor{gnat_ugn/the_gnat_compilation_model id23}@anchor{6d}@anchor{gnat_ugn/the_gnat_compilation_model handling-files-with-multiple-units}@anchor{6e} +@anchor{gnat_ugn/the_gnat_compilation_model id23}@anchor{56}@anchor{gnat_ugn/the_gnat_compilation_model handling-files-with-multiple-units}@anchor{57} @subsubsection Handling Files with Multiple Units @@ -2637,7 +2424,7 @@ perhaps to maintain compatibility with some other Ada compilation system, you can use @code{gnatname} to generate or update your project files. Generated or modified project files can be processed by GNAT. -See @ref{59,,Handling Arbitrary File Naming Conventions with gnatname} +See @ref{42,,Handling Arbitrary File Naming Conventions with gnatname} for more details on how to use @cite{gnatname}. Alternatively, if you want to permanently restructure a set of 'foreign' @@ -2651,7 +2438,7 @@ will each start with a copy of this BOM, meaning that they can be compiled automatically in UTF-8 mode without needing to specify an explicit encoding. @node Operating gnatchop in Compilation Mode,Command Line for gnatchop,Handling Files with Multiple Units,Renaming Files with gnatchop -@anchor{gnat_ugn/the_gnat_compilation_model operating-gnatchop-in-compilation-mode}@anchor{6f}@anchor{gnat_ugn/the_gnat_compilation_model id24}@anchor{70} +@anchor{gnat_ugn/the_gnat_compilation_model operating-gnatchop-in-compilation-mode}@anchor{58}@anchor{gnat_ugn/the_gnat_compilation_model id24}@anchor{59} @subsubsection Operating gnatchop in Compilation Mode @@ -2684,7 +2471,7 @@ should apply to all subsequent compilations in the same compilation environment. Using GNAT, the current directory, possibly containing a @code{gnat.adc} file is the representation of a compilation environment. For more information on the -@code{gnat.adc} file, see @ref{56,,Handling of Configuration Pragmas}. +@code{gnat.adc} file, see @ref{3f,,Handling of Configuration Pragmas}. Second, in compilation mode, if @code{gnatchop} is given a file that starts with @@ -2711,7 +2498,7 @@ switch provides the required behavior, and is for example the mode in which GNAT processes the ACVC tests. @node Command Line for gnatchop,Switches for gnatchop,Operating gnatchop in Compilation Mode,Renaming Files with gnatchop -@anchor{gnat_ugn/the_gnat_compilation_model id25}@anchor{71}@anchor{gnat_ugn/the_gnat_compilation_model command-line-for-gnatchop}@anchor{72} +@anchor{gnat_ugn/the_gnat_compilation_model id25}@anchor{5a}@anchor{gnat_ugn/the_gnat_compilation_model command-line-for-gnatchop}@anchor{5b} @subsubsection Command Line for @code{gnatchop} @@ -2785,7 +2572,7 @@ no source files written @end example @node Switches for gnatchop,Examples of gnatchop Usage,Command Line for gnatchop,Renaming Files with gnatchop -@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatchop}@anchor{73}@anchor{gnat_ugn/the_gnat_compilation_model id26}@anchor{74} +@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatchop}@anchor{5c}@anchor{gnat_ugn/the_gnat_compilation_model id26}@anchor{5d} @subsubsection Switches for @code{gnatchop} @@ -2951,7 +2738,7 @@ no attempt is made to add the prefix to the GNAT parser executable. @end table @node Examples of gnatchop Usage,,Switches for gnatchop,Renaming Files with gnatchop -@anchor{gnat_ugn/the_gnat_compilation_model id27}@anchor{75}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatchop-usage}@anchor{76} +@anchor{gnat_ugn/the_gnat_compilation_model id27}@anchor{5e}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatchop-usage}@anchor{5f} @subsubsection Examples of @code{gnatchop} Usage @@ -2992,7 +2779,7 @@ be the one that is output, and earlier duplicate occurrences for a given unit will be skipped. @node Configuration Pragmas,Generating Object Files,File Naming Topics and Utilities,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model id28}@anchor{77}@anchor{gnat_ugn/the_gnat_compilation_model configuration-pragmas}@anchor{14} +@anchor{gnat_ugn/the_gnat_compilation_model id28}@anchor{60}@anchor{gnat_ugn/the_gnat_compilation_model configuration-pragmas}@anchor{25} @section Configuration Pragmas @@ -3103,7 +2890,7 @@ Wide_Character_Encoding @end menu @node Handling of Configuration Pragmas,The Configuration Pragmas Files,,Configuration Pragmas -@anchor{gnat_ugn/the_gnat_compilation_model id29}@anchor{78}@anchor{gnat_ugn/the_gnat_compilation_model handling-of-configuration-pragmas}@anchor{56} +@anchor{gnat_ugn/the_gnat_compilation_model id29}@anchor{61}@anchor{gnat_ugn/the_gnat_compilation_model handling-of-configuration-pragmas}@anchor{3f} @subsection Handling of Configuration Pragmas @@ -3114,7 +2901,7 @@ all compilations performed in a given compilation environment. GNAT also provides the @code{gnatchop} utility to provide an automatic way to handle configuration pragmas following the semantics for compilations (that is, files with multiple units), described in the RM. -See @ref{6f,,Operating gnatchop in Compilation Mode} for details. +See @ref{58,,Operating gnatchop in Compilation Mode} for details. However, for most purposes, it will be more convenient to edit the @code{gnat.adc} file that contains configuration pragmas directly, as described in the following section. @@ -3144,7 +2931,7 @@ relevant units). It can appear on a subunit only if it has previously appeared in the body of spec. @node The Configuration Pragmas Files,,Handling of Configuration Pragmas,Configuration Pragmas -@anchor{gnat_ugn/the_gnat_compilation_model the-configuration-pragmas-files}@anchor{79}@anchor{gnat_ugn/the_gnat_compilation_model id30}@anchor{7a} +@anchor{gnat_ugn/the_gnat_compilation_model the-configuration-pragmas-files}@anchor{62}@anchor{gnat_ugn/the_gnat_compilation_model id30}@anchor{63} @subsection The Configuration Pragmas Files @@ -3191,7 +2978,7 @@ project attributes. @c See :ref:`Specifying_Configuration_Pragmas` for more details. @node Generating Object Files,Source Dependencies,Configuration Pragmas,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model generating-object-files}@anchor{40}@anchor{gnat_ugn/the_gnat_compilation_model id31}@anchor{7b} +@anchor{gnat_ugn/the_gnat_compilation_model generating-object-files}@anchor{26}@anchor{gnat_ugn/the_gnat_compilation_model id31}@anchor{64} @section Generating Object Files @@ -3262,7 +3049,7 @@ part of the process of building a program. To compile a file in this checking mode, use the @code{-gnatc} switch. @node Source Dependencies,The Ada Library Information Files,Generating Object Files,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model id32}@anchor{7c}@anchor{gnat_ugn/the_gnat_compilation_model source-dependencies}@anchor{41} +@anchor{gnat_ugn/the_gnat_compilation_model id32}@anchor{65}@anchor{gnat_ugn/the_gnat_compilation_model source-dependencies}@anchor{27} @section Source Dependencies @@ -3357,7 +3144,7 @@ recompilations is done automatically when one uses @code{gnatmake}. @end itemize @node The Ada Library Information Files,Binding an Ada Program,Source Dependencies,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model id33}@anchor{7d}@anchor{gnat_ugn/the_gnat_compilation_model the-ada-library-information-files}@anchor{42} +@anchor{gnat_ugn/the_gnat_compilation_model id33}@anchor{66}@anchor{gnat_ugn/the_gnat_compilation_model the-ada-library-information-files}@anchor{28} @section The Ada Library Information Files @@ -3425,7 +3212,7 @@ see the source of the body of unit @code{Lib.Writ}, contained in file @code{lib-writ.adb} in the GNAT compiler sources. @node Binding an Ada Program,GNAT and Libraries,The Ada Library Information Files,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model id34}@anchor{7e}@anchor{gnat_ugn/the_gnat_compilation_model binding-an-ada-program}@anchor{43} +@anchor{gnat_ugn/the_gnat_compilation_model id34}@anchor{67}@anchor{gnat_ugn/the_gnat_compilation_model binding-an-ada-program}@anchor{29} @section Binding an Ada Program @@ -3461,7 +3248,7 @@ using the object from the main program from the bind step as well as the object files for the Ada units of the program. @node GNAT and Libraries,Conditional Compilation,Binding an Ada Program,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-libraries}@anchor{15}@anchor{gnat_ugn/the_gnat_compilation_model id35}@anchor{7f} +@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-libraries}@anchor{2a}@anchor{gnat_ugn/the_gnat_compilation_model id35}@anchor{68} @section GNAT and Libraries @@ -3481,7 +3268,7 @@ Project Manager facility (see the @emph{GNAT_Project_Manager} chapter of the @end menu @node Introduction to Libraries in GNAT,General Ada Libraries,,GNAT and Libraries -@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-libraries-in-gnat}@anchor{80}@anchor{gnat_ugn/the_gnat_compilation_model id36}@anchor{81} +@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-libraries-in-gnat}@anchor{69}@anchor{gnat_ugn/the_gnat_compilation_model id36}@anchor{6a} @subsection Introduction to Libraries in GNAT @@ -3508,7 +3295,7 @@ In the GNAT environment, a library has three types of components: Source files, @item -@code{ALI} files (see @ref{42,,The Ada Library Information Files}), and +@code{ALI} files (see @ref{28,,The Ada Library Information Files}), and @item Object files, an archive or a shared library. @@ -3520,7 +3307,7 @@ an external user to make use of the library. That is to say, the specs reflecting the library services along with all the units needed to compile those specs, which can include generic bodies or any body implementing an inlined routine. In the case of @emph{stand-alone libraries} those exposed -units are called @emph{interface units} (@ref{82,,Stand-alone Ada Libraries}). +units are called @emph{interface units} (@ref{6b,,Stand-alone Ada Libraries}). All compilation units comprising an application, including those in a library, need to be elaborated in an order partially defined by Ada's semantics. GNAT @@ -3531,7 +3318,7 @@ library elaboration routine is produced independently of the application(s) using the library. @node General Ada Libraries,Stand-alone Ada Libraries,Introduction to Libraries in GNAT,GNAT and Libraries -@anchor{gnat_ugn/the_gnat_compilation_model general-ada-libraries}@anchor{83}@anchor{gnat_ugn/the_gnat_compilation_model id37}@anchor{84} +@anchor{gnat_ugn/the_gnat_compilation_model general-ada-libraries}@anchor{6c}@anchor{gnat_ugn/the_gnat_compilation_model id37}@anchor{6d} @subsection General Ada Libraries @@ -3543,7 +3330,7 @@ using the library. @end menu @node Building a library,Installing a library,,General Ada Libraries -@anchor{gnat_ugn/the_gnat_compilation_model building-a-library}@anchor{85}@anchor{gnat_ugn/the_gnat_compilation_model id38}@anchor{86} +@anchor{gnat_ugn/the_gnat_compilation_model building-a-library}@anchor{6e}@anchor{gnat_ugn/the_gnat_compilation_model id38}@anchor{6f} @subsubsection Building a library @@ -3625,7 +3412,7 @@ for this task. In special cases where this is not desired, the necessary steps are discussed below. There are various possibilities for compiling the units that make up the -library: for example with a Makefile (@ref{1f,,Using the GNU make Utility}) or +library: for example with a Makefile (@ref{70,,Using the GNU make Utility}) or with a conventional script. For simple libraries, it is also possible to create a dummy main program which depends upon all the packages that comprise the interface of the library. This dummy main program can then be given to @@ -3676,7 +3463,7 @@ or @code{lib@emph{xxx}.so} (or @code{lib@emph{xxx}.dll} on Windows) in order to be accessed by the directive @code{-l@emph{xxx}} at link time. @node Installing a library,Using a library,Building a library,General Ada Libraries -@anchor{gnat_ugn/the_gnat_compilation_model installing-a-library}@anchor{87}@anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{88} +@anchor{gnat_ugn/the_gnat_compilation_model installing-a-library}@anchor{71}@anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{72} @subsubsection Installing a library @@ -3691,7 +3478,7 @@ process (see the @emph{Installing a Library with Project Files} section of the When project files are not an option, it is also possible, but not recommended, to install the library so that the sources needed to use the library are on the Ada source path and the ALI files & libraries be on the Ada Object path (see -@ref{89,,Search Paths and the Run-Time Library (RTL)}. Alternatively, the system +@ref{73,,Search Paths and the Run-Time Library (RTL)}. Alternatively, the system administrator can place general-purpose libraries in the default compiler paths, by specifying the libraries' location in the configuration files @code{ada_source_path} and @code{ada_object_path}. These configuration files @@ -3733,7 +3520,7 @@ library must be installed before the GNAT library if it redefines any part of it. @node Using a library,,Installing a library,General Ada Libraries -@anchor{gnat_ugn/the_gnat_compilation_model using-a-library}@anchor{8a}@anchor{gnat_ugn/the_gnat_compilation_model id40}@anchor{8b} +@anchor{gnat_ugn/the_gnat_compilation_model using-a-library}@anchor{74}@anchor{gnat_ugn/the_gnat_compilation_model id40}@anchor{75} @subsubsection Using a library @@ -3772,8 +3559,8 @@ left to the tools having visibility over project dependence information. In order to use an Ada library manually, you need to make sure that this library is on both your source and object path -(see @ref{89,,Search Paths and the Run-Time Library (RTL)} -and @ref{8c,,Search Paths for gnatbind}). Furthermore, when the objects are grouped +(see @ref{73,,Search Paths and the Run-Time Library (RTL)} +and @ref{76,,Search Paths for gnatbind}). Furthermore, when the objects are grouped in an archive or a shared library, you need to specify the desired library at link time. @@ -3827,7 +3614,7 @@ in the directory @code{share/examples/gnat/plugins} within the GNAT install area. @node Stand-alone Ada Libraries,Rebuilding the GNAT Run-Time Library,General Ada Libraries,GNAT and Libraries -@anchor{gnat_ugn/the_gnat_compilation_model stand-alone-ada-libraries}@anchor{82}@anchor{gnat_ugn/the_gnat_compilation_model id41}@anchor{8d} +@anchor{gnat_ugn/the_gnat_compilation_model stand-alone-ada-libraries}@anchor{6b}@anchor{gnat_ugn/the_gnat_compilation_model id41}@anchor{77} @subsection Stand-alone Ada Libraries @@ -3842,7 +3629,7 @@ install area. @end menu @node Introduction to Stand-alone Libraries,Building a Stand-alone Library,,Stand-alone Ada Libraries -@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-stand-alone-libraries}@anchor{8e}@anchor{gnat_ugn/the_gnat_compilation_model id42}@anchor{8f} +@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-stand-alone-libraries}@anchor{78}@anchor{gnat_ugn/the_gnat_compilation_model id42}@anchor{79} @subsubsection Introduction to Stand-alone Libraries @@ -3877,7 +3664,7 @@ Stand-alone libraries are also well suited to be used in an executable whose main routine is not written in Ada. @node Building a Stand-alone Library,Creating a Stand-alone Library to be used in a non-Ada context,Introduction to Stand-alone Libraries,Stand-alone Ada Libraries -@anchor{gnat_ugn/the_gnat_compilation_model id43}@anchor{90}@anchor{gnat_ugn/the_gnat_compilation_model building-a-stand-alone-library}@anchor{91} +@anchor{gnat_ugn/the_gnat_compilation_model id43}@anchor{7a}@anchor{gnat_ugn/the_gnat_compilation_model building-a-stand-alone-library}@anchor{7b} @subsubsection Building a Stand-alone Library @@ -3996,10 +3783,10 @@ read-only. @end itemize Using SALs is not different from using other libraries -(see @ref{8a,,Using a library}). +(see @ref{74,,Using a library}). @node Creating a Stand-alone Library to be used in a non-Ada context,Restrictions in Stand-alone Libraries,Building a Stand-alone Library,Stand-alone Ada Libraries -@anchor{gnat_ugn/the_gnat_compilation_model creating-a-stand-alone-library-to-be-used-in-a-non-ada-context}@anchor{92}@anchor{gnat_ugn/the_gnat_compilation_model id44}@anchor{93} +@anchor{gnat_ugn/the_gnat_compilation_model creating-a-stand-alone-library-to-be-used-in-a-non-ada-context}@anchor{7c}@anchor{gnat_ugn/the_gnat_compilation_model id44}@anchor{7d} @subsubsection Creating a Stand-alone Library to be used in a non-Ada context @@ -4084,7 +3871,7 @@ must be ensured at the application level using a specific operating system services like a mutex or a critical-section. @node Restrictions in Stand-alone Libraries,,Creating a Stand-alone Library to be used in a non-Ada context,Stand-alone Ada Libraries -@anchor{gnat_ugn/the_gnat_compilation_model id45}@anchor{94}@anchor{gnat_ugn/the_gnat_compilation_model restrictions-in-stand-alone-libraries}@anchor{95} +@anchor{gnat_ugn/the_gnat_compilation_model id45}@anchor{7e}@anchor{gnat_ugn/the_gnat_compilation_model restrictions-in-stand-alone-libraries}@anchor{7f} @subsubsection Restrictions in Stand-alone Libraries @@ -4130,7 +3917,7 @@ In practice these attributes are rarely used, so this is unlikely to be a consideration. @node Rebuilding the GNAT Run-Time Library,,Stand-alone Ada Libraries,GNAT and Libraries -@anchor{gnat_ugn/the_gnat_compilation_model id46}@anchor{96}@anchor{gnat_ugn/the_gnat_compilation_model rebuilding-the-gnat-run-time-library}@anchor{97} +@anchor{gnat_ugn/the_gnat_compilation_model id46}@anchor{80}@anchor{gnat_ugn/the_gnat_compilation_model rebuilding-the-gnat-run-time-library}@anchor{81} @subsection Rebuilding the GNAT Run-Time Library @@ -4166,7 +3953,7 @@ experiments or debugging, and is not supported. @geindex Conditional compilation @node Conditional Compilation,Mixed Language Programming,GNAT and Libraries,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model id47}@anchor{98}@anchor{gnat_ugn/the_gnat_compilation_model conditional-compilation}@anchor{16} +@anchor{gnat_ugn/the_gnat_compilation_model id47}@anchor{82}@anchor{gnat_ugn/the_gnat_compilation_model conditional-compilation}@anchor{2b} @section Conditional Compilation @@ -4183,7 +3970,7 @@ gnatprep preprocessor utility. @end menu @node Modeling Conditional Compilation in Ada,Preprocessing with gnatprep,,Conditional Compilation -@anchor{gnat_ugn/the_gnat_compilation_model modeling-conditional-compilation-in-ada}@anchor{99}@anchor{gnat_ugn/the_gnat_compilation_model id48}@anchor{9a} +@anchor{gnat_ugn/the_gnat_compilation_model modeling-conditional-compilation-in-ada}@anchor{83}@anchor{gnat_ugn/the_gnat_compilation_model id48}@anchor{84} @subsection Modeling Conditional Compilation in Ada @@ -4234,7 +4021,7 @@ be achieved using Ada in general, and GNAT in particular. @end menu @node Use of Boolean Constants,Debugging - A Special Case,,Modeling Conditional Compilation in Ada -@anchor{gnat_ugn/the_gnat_compilation_model id49}@anchor{9b}@anchor{gnat_ugn/the_gnat_compilation_model use-of-boolean-constants}@anchor{9c} +@anchor{gnat_ugn/the_gnat_compilation_model id49}@anchor{85}@anchor{gnat_ugn/the_gnat_compilation_model use-of-boolean-constants}@anchor{86} @subsubsection Use of Boolean Constants @@ -4278,7 +4065,7 @@ Then any other unit requiring conditional compilation can do a @emph{with} of @code{Config} to make the constants visible. @node Debugging - A Special Case,Conditionalizing Declarations,Use of Boolean Constants,Modeling Conditional Compilation in Ada -@anchor{gnat_ugn/the_gnat_compilation_model debugging-a-special-case}@anchor{9d}@anchor{gnat_ugn/the_gnat_compilation_model id50}@anchor{9e} +@anchor{gnat_ugn/the_gnat_compilation_model debugging-a-special-case}@anchor{87}@anchor{gnat_ugn/the_gnat_compilation_model id50}@anchor{88} @subsubsection Debugging - A Special Case @@ -4391,7 +4178,7 @@ end if; @end example @node Conditionalizing Declarations,Use of Alternative Implementations,Debugging - A Special Case,Modeling Conditional Compilation in Ada -@anchor{gnat_ugn/the_gnat_compilation_model conditionalizing-declarations}@anchor{9f}@anchor{gnat_ugn/the_gnat_compilation_model id51}@anchor{a0} +@anchor{gnat_ugn/the_gnat_compilation_model conditionalizing-declarations}@anchor{89}@anchor{gnat_ugn/the_gnat_compilation_model id51}@anchor{8a} @subsubsection Conditionalizing Declarations @@ -4456,7 +4243,7 @@ constant was introduced as @code{System.Default_Bit_Order}, so you do not need to define this one yourself). @node Use of Alternative Implementations,Preprocessing,Conditionalizing Declarations,Modeling Conditional Compilation in Ada -@anchor{gnat_ugn/the_gnat_compilation_model use-of-alternative-implementations}@anchor{a1}@anchor{gnat_ugn/the_gnat_compilation_model id52}@anchor{a2} +@anchor{gnat_ugn/the_gnat_compilation_model use-of-alternative-implementations}@anchor{8b}@anchor{gnat_ugn/the_gnat_compilation_model id52}@anchor{8c} @subsubsection Use of Alternative Implementations @@ -4590,7 +4377,7 @@ The same idea can also be implemented using tagged types and dispatching calls. @node Preprocessing,,Use of Alternative Implementations,Modeling Conditional Compilation in Ada -@anchor{gnat_ugn/the_gnat_compilation_model preprocessing}@anchor{a3}@anchor{gnat_ugn/the_gnat_compilation_model id53}@anchor{a4} +@anchor{gnat_ugn/the_gnat_compilation_model preprocessing}@anchor{8d}@anchor{gnat_ugn/the_gnat_compilation_model id53}@anchor{8e} @subsubsection Preprocessing @@ -4613,7 +4400,7 @@ The preprocessor may be used in two separate modes. It can be used quite separately from the compiler, to generate a separate output source file that is then fed to the compiler as a separate step. This is the @code{gnatprep} utility, whose use is fully described in -@ref{17,,Preprocessing with gnatprep}. +@ref{8f,,Preprocessing with gnatprep}. The preprocessing language allows such constructs as @@ -4633,10 +4420,10 @@ often more convenient. In this approach the preprocessing is integrated into the compilation process. The compiler is given the preprocessor input which includes @code{#if} lines etc, and then the compiler carries out the preprocessing internally and processes the resulting output. -For more details on this approach, see @ref{18,,Integrated Preprocessing}. +For more details on this approach, see @ref{90,,Integrated Preprocessing}. @node Preprocessing with gnatprep,Integrated Preprocessing,Modeling Conditional Compilation in Ada,Conditional Compilation -@anchor{gnat_ugn/the_gnat_compilation_model id54}@anchor{a5}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-with-gnatprep}@anchor{17} +@anchor{gnat_ugn/the_gnat_compilation_model id54}@anchor{91}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-with-gnatprep}@anchor{8f} @subsection Preprocessing with @code{gnatprep} @@ -4649,7 +4436,7 @@ preprocessing. Although designed for use with GNAT, @code{gnatprep} does not depend on any special GNAT features. For further discussion of conditional compilation in general, see -@ref{16,,Conditional Compilation}. +@ref{2b,,Conditional Compilation}. @menu * Preprocessing Symbols:: @@ -4661,7 +4448,7 @@ For further discussion of conditional compilation in general, see @end menu @node Preprocessing Symbols,Using gnatprep,,Preprocessing with gnatprep -@anchor{gnat_ugn/the_gnat_compilation_model id55}@anchor{a6}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-symbols}@anchor{a7} +@anchor{gnat_ugn/the_gnat_compilation_model id55}@anchor{92}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-symbols}@anchor{93} @subsubsection Preprocessing Symbols @@ -4671,7 +4458,7 @@ normal Ada (case-insensitive) rules for its syntax, with the restriction that all characters need to be in the ASCII set (no accented letters). @node Using gnatprep,Switches for gnatprep,Preprocessing Symbols,Preprocessing with gnatprep -@anchor{gnat_ugn/the_gnat_compilation_model using-gnatprep}@anchor{a8}@anchor{gnat_ugn/the_gnat_compilation_model id56}@anchor{a9} +@anchor{gnat_ugn/the_gnat_compilation_model using-gnatprep}@anchor{94}@anchor{gnat_ugn/the_gnat_compilation_model id56}@anchor{95} @subsubsection Using @code{gnatprep} @@ -4729,7 +4516,7 @@ optional, and can be replaced by the use of the @code{-D} switch. @end itemize @node Switches for gnatprep,Form of Definitions File,Using gnatprep,Preprocessing with gnatprep -@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatprep}@anchor{aa}@anchor{gnat_ugn/the_gnat_compilation_model id57}@anchor{ab} +@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatprep}@anchor{96}@anchor{gnat_ugn/the_gnat_compilation_model id57}@anchor{97} @subsubsection Switches for @code{gnatprep} @@ -4880,7 +4667,7 @@ deleted lines are completely removed from the output, unless -r is specified, in which case -b is assumed. @node Form of Definitions File,Form of Input Text for gnatprep,Switches for gnatprep,Preprocessing with gnatprep -@anchor{gnat_ugn/the_gnat_compilation_model form-of-definitions-file}@anchor{ac}@anchor{gnat_ugn/the_gnat_compilation_model id58}@anchor{ad} +@anchor{gnat_ugn/the_gnat_compilation_model form-of-definitions-file}@anchor{98}@anchor{gnat_ugn/the_gnat_compilation_model id58}@anchor{99} @subsubsection Form of Definitions File @@ -4910,7 +4697,7 @@ the usual @code{--}, and comments may be added to the definitions lines. @node Form of Input Text for gnatprep,,Form of Definitions File,Preprocessing with gnatprep -@anchor{gnat_ugn/the_gnat_compilation_model id59}@anchor{ae}@anchor{gnat_ugn/the_gnat_compilation_model form-of-input-text-for-gnatprep}@anchor{af} +@anchor{gnat_ugn/the_gnat_compilation_model id59}@anchor{9a}@anchor{gnat_ugn/the_gnat_compilation_model form-of-input-text-for-gnatprep}@anchor{9b} @subsubsection Form of Input Text for @code{gnatprep} @@ -5042,7 +4829,7 @@ Header : String := $XYZ; and then the substitution will occur as desired. @node Integrated Preprocessing,,Preprocessing with gnatprep,Conditional Compilation -@anchor{gnat_ugn/the_gnat_compilation_model id60}@anchor{b0}@anchor{gnat_ugn/the_gnat_compilation_model integrated-preprocessing}@anchor{18} +@anchor{gnat_ugn/the_gnat_compilation_model id60}@anchor{9c}@anchor{gnat_ugn/the_gnat_compilation_model integrated-preprocessing}@anchor{90} @subsection Integrated Preprocessing @@ -5103,7 +4890,7 @@ because @code{gnatmake} cannot compute the checksum of the source after preprocessing. The actual preprocessing function is described in detail in -@ref{17,,Preprocessing with gnatprep}. This section explains the switches +@ref{8f,,Preprocessing with gnatprep}. This section explains the switches that relate to integrated preprocessing. @geindex -gnatep (gcc) @@ -5202,7 +4989,7 @@ lines starting with the character '*'. After the file name or '*', an optional literal string specifies the name of the definition file to be used for preprocessing -(@ref{ac,,Form of Definitions File}). The definition files are found by the +(@ref{98,,Form of Definitions File}). The definition files are found by the compiler in one of the source directories. In some cases, when compiling a source in a directory other than the current directory, if the definition file is in the current directory, it may be necessary to add the current @@ -5294,7 +5081,7 @@ the output file will be @code{foo.adb.prep}. @end table @node Mixed Language Programming,GNAT and Other Compilation Models,Conditional Compilation,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model mixed-language-programming}@anchor{44}@anchor{gnat_ugn/the_gnat_compilation_model id61}@anchor{b1} +@anchor{gnat_ugn/the_gnat_compilation_model mixed-language-programming}@anchor{2c}@anchor{gnat_ugn/the_gnat_compilation_model id61}@anchor{9d} @section Mixed Language Programming @@ -5313,7 +5100,7 @@ with a focus on combining Ada with C or C++. @end menu @node Interfacing to C,Calling Conventions,,Mixed Language Programming -@anchor{gnat_ugn/the_gnat_compilation_model interfacing-to-c}@anchor{b2}@anchor{gnat_ugn/the_gnat_compilation_model id62}@anchor{b3} +@anchor{gnat_ugn/the_gnat_compilation_model interfacing-to-c}@anchor{9e}@anchor{gnat_ugn/the_gnat_compilation_model id62}@anchor{9f} @subsection Interfacing to C @@ -5424,7 +5211,7 @@ $ gnatmake my_main.adb -largs file1.o file2.o If the main program is in a language other than Ada, then you may have more than one entry point into the Ada subsystem. You must use a special binder option to generate callable routines that initialize and -finalize the Ada units (@ref{b4,,Binding with Non-Ada Main Programs}). +finalize the Ada units (@ref{a0,,Binding with Non-Ada Main Programs}). Calls to the initialization and finalization routines must be inserted in the main program, or some other appropriate point in the code. The call to initialize the Ada units must occur before the first Ada @@ -5540,7 +5327,7 @@ GNAT linker not to include the standard startup objects by passing the @code{-nostartfiles} switch to @code{gnatlink}. @node Calling Conventions,Building Mixed Ada and C++ Programs,Interfacing to C,Mixed Language Programming -@anchor{gnat_ugn/the_gnat_compilation_model calling-conventions}@anchor{b5}@anchor{gnat_ugn/the_gnat_compilation_model id63}@anchor{b6} +@anchor{gnat_ugn/the_gnat_compilation_model calling-conventions}@anchor{a1}@anchor{gnat_ugn/the_gnat_compilation_model id63}@anchor{a2} @subsection Calling Conventions @@ -5864,7 +5651,7 @@ identifier (for example in an @code{Import} pragma) with the same meaning as Fortran. @node Building Mixed Ada and C++ Programs,Generating Ada Bindings for C and C++ headers,Calling Conventions,Mixed Language Programming -@anchor{gnat_ugn/the_gnat_compilation_model id64}@anchor{b7}@anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{b8} +@anchor{gnat_ugn/the_gnat_compilation_model id64}@anchor{a3}@anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{a4} @subsection Building Mixed Ada and C++ Programs @@ -5882,7 +5669,7 @@ challenge. This section gives a few hints that should make this task easier. @end menu @node Interfacing to C++,Linking a Mixed C++ & Ada Program,,Building Mixed Ada and C++ Programs -@anchor{gnat_ugn/the_gnat_compilation_model id65}@anchor{b9}@anchor{gnat_ugn/the_gnat_compilation_model id66}@anchor{ba} +@anchor{gnat_ugn/the_gnat_compilation_model id65}@anchor{a5}@anchor{gnat_ugn/the_gnat_compilation_model id66}@anchor{a6} @subsubsection Interfacing to C++ @@ -5894,7 +5681,7 @@ Interfacing can be done at 3 levels: simple data, subprograms, and classes. In the first two cases, GNAT offers a specific @code{Convention C_Plus_Plus} (or @code{CPP}) that behaves exactly like @code{Convention C}. Usually, C++ mangles the names of subprograms. To generate proper mangled -names automatically, see @ref{19,,Generating Ada Bindings for C and C++ headers}). +names automatically, see @ref{a7,,Generating Ada Bindings for C and C++ headers}). This problem can also be addressed manually in two ways: @@ -5913,7 +5700,7 @@ Interfacing at the class level can be achieved by using the GNAT specific pragmas such as @code{CPP_Constructor}. See the @cite{GNAT_Reference_Manual} for additional information. @node Linking a Mixed C++ & Ada Program,A Simple Example,Interfacing to C++,Building Mixed Ada and C++ Programs -@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-ada-program}@anchor{bb}@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-and-ada-program}@anchor{bc} +@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-ada-program}@anchor{a8}@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-and-ada-program}@anchor{a9} @subsubsection Linking a Mixed C++ & Ada Program @@ -6028,7 +5815,7 @@ which has a large knowledge base and knows how to link Ada and C++ code together automatically in most cases. @node A Simple Example,Interfacing with C++ constructors,Linking a Mixed C++ & Ada Program,Building Mixed Ada and C++ Programs -@anchor{gnat_ugn/the_gnat_compilation_model id67}@anchor{bd}@anchor{gnat_ugn/the_gnat_compilation_model a-simple-example}@anchor{be} +@anchor{gnat_ugn/the_gnat_compilation_model id67}@anchor{aa}@anchor{gnat_ugn/the_gnat_compilation_model a-simple-example}@anchor{ab} @subsubsection A Simple Example @@ -6157,7 +5944,7 @@ end Simple_Cpp_Interface; @end example @node Interfacing with C++ constructors,Interfacing with C++ at the Class Level,A Simple Example,Building Mixed Ada and C++ Programs -@anchor{gnat_ugn/the_gnat_compilation_model id68}@anchor{bf}@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-constructors}@anchor{c0} +@anchor{gnat_ugn/the_gnat_compilation_model id68}@anchor{ac}@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-constructors}@anchor{ad} @subsubsection Interfacing with C++ constructors @@ -6184,8 +5971,8 @@ public: For this purpose we can write the following package spec (further information on how to build this spec is available in -@ref{c1,,Interfacing with C++ at the Class Level} and -@ref{19,,Generating Ada Bindings for C and C++ headers}). +@ref{ae,,Interfacing with C++ at the Class Level} and +@ref{a7,,Generating Ada Bindings for C and C++ headers}). @example with Interfaces.C; use Interfaces.C; @@ -6354,7 +6141,7 @@ by means of a limited aggregate. Any further action associated with the constructor can be placed inside the construct. @node Interfacing with C++ at the Class Level,,Interfacing with C++ constructors,Building Mixed Ada and C++ Programs -@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-at-the-class-level}@anchor{c1}@anchor{gnat_ugn/the_gnat_compilation_model id69}@anchor{c2} +@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-at-the-class-level}@anchor{ae}@anchor{gnat_ugn/the_gnat_compilation_model id69}@anchor{af} @subsubsection Interfacing with C++ at the Class Level @@ -6600,7 +6387,7 @@ int main () @end example @node Generating Ada Bindings for C and C++ headers,Generating C Headers for Ada Specifications,Building Mixed Ada and C++ Programs,Mixed Language Programming -@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{c3}@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{19} +@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{b0}@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{a7} @subsection Generating Ada Bindings for C and C++ headers @@ -6651,7 +6438,7 @@ even if your code is compiled using earlier versions of Ada (e.g. @code{-gnat95} @end menu @node Running the Binding Generator,Generating Bindings for C++ Headers,,Generating Ada Bindings for C and C++ headers -@anchor{gnat_ugn/the_gnat_compilation_model id71}@anchor{c4}@anchor{gnat_ugn/the_gnat_compilation_model running-the-binding-generator}@anchor{c5} +@anchor{gnat_ugn/the_gnat_compilation_model id71}@anchor{b1}@anchor{gnat_ugn/the_gnat_compilation_model running-the-binding-generator}@anchor{b2} @subsubsection Running the Binding Generator @@ -6745,7 +6532,7 @@ $ g++ -c -fdump-ada-spec readline1.h @end example @node Generating Bindings for C++ Headers,Switches,Running the Binding Generator,Generating Ada Bindings for C and C++ headers -@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{c6}@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{c7} +@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{b3}@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{b4} @subsubsection Generating Bindings for C++ Headers @@ -6846,7 +6633,7 @@ use Class_Dog; @end example @node Switches,,Generating Bindings for C++ Headers,Generating Ada Bindings for C and C++ headers -@anchor{gnat_ugn/the_gnat_compilation_model switches}@anchor{c8}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-ada-binding-generation}@anchor{c9} +@anchor{gnat_ugn/the_gnat_compilation_model switches}@anchor{b5}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-ada-binding-generation}@anchor{b6} @subsubsection Switches @@ -6894,7 +6681,7 @@ Extract comments from headers and generate Ada comments in the Ada spec files. @end table @node Generating C Headers for Ada Specifications,,Generating Ada Bindings for C and C++ headers,Mixed Language Programming -@anchor{gnat_ugn/the_gnat_compilation_model generating-c-headers-for-ada-specifications}@anchor{ca}@anchor{gnat_ugn/the_gnat_compilation_model id73}@anchor{cb} +@anchor{gnat_ugn/the_gnat_compilation_model generating-c-headers-for-ada-specifications}@anchor{b7}@anchor{gnat_ugn/the_gnat_compilation_model id73}@anchor{b8} @subsection Generating C Headers for Ada Specifications @@ -6937,7 +6724,7 @@ Subprogram declarations @end menu @node Running the C Header Generator,,,Generating C Headers for Ada Specifications -@anchor{gnat_ugn/the_gnat_compilation_model running-the-c-header-generator}@anchor{cc} +@anchor{gnat_ugn/the_gnat_compilation_model running-the-c-header-generator}@anchor{b9} @subsubsection Running the C Header Generator @@ -7005,7 +6792,7 @@ You can then @code{include} @code{pack1.h} from a C source file and use the type call subprograms, reference objects, and constants. @node GNAT and Other Compilation Models,Using GNAT Files with External Tools,Mixed Language Programming,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{cd}@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{45} +@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{ba}@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{2d} @section GNAT and Other Compilation Models @@ -7021,7 +6808,7 @@ used for Ada 83. @end menu @node Comparison between GNAT and C/C++ Compilation Models,Comparison between GNAT and Conventional Ada Library Models,,GNAT and Other Compilation Models -@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-c-c-compilation-models}@anchor{ce}@anchor{gnat_ugn/the_gnat_compilation_model id75}@anchor{cf} +@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-c-c-compilation-models}@anchor{bb}@anchor{gnat_ugn/the_gnat_compilation_model id75}@anchor{bc} @subsection Comparison between GNAT and C/C++ Compilation Models @@ -7055,7 +6842,7 @@ elaboration, a C++ compiler would simply construct a program that malfunctioned at run time. @node Comparison between GNAT and Conventional Ada Library Models,,Comparison between GNAT and C/C++ Compilation Models,GNAT and Other Compilation Models -@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-conventional-ada-library-models}@anchor{d0}@anchor{gnat_ugn/the_gnat_compilation_model id76}@anchor{d1} +@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-conventional-ada-library-models}@anchor{bd}@anchor{gnat_ugn/the_gnat_compilation_model id76}@anchor{be} @subsection Comparison between GNAT and Conventional Ada Library Models @@ -7123,7 +6910,7 @@ of rules saying what source files must be present when a file is compiled. @node Using GNAT Files with External Tools,,GNAT and Other Compilation Models,The GNAT Compilation Model -@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{1a}@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{d2} +@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{2e}@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{bf} @section Using GNAT Files with External Tools @@ -7137,7 +6924,7 @@ used with tools designed for other languages. @end menu @node Using Other Utility Programs with GNAT,The External Symbol Naming Scheme of GNAT,,Using GNAT Files with External Tools -@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{d3}@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{d4} +@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{c0}@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{c1} @subsection Using Other Utility Programs with GNAT @@ -7152,7 +6939,7 @@ gprof (a profiling program), gdb (the FSF debugger), and utilities such as Purify. @node The External Symbol Naming Scheme of GNAT,,Using Other Utility Programs with GNAT,Using GNAT Files with External Tools -@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{d5}@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{d6} +@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{c2}@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{c3} @subsection The External Symbol Naming Scheme of GNAT @@ -7211,23 +6998,23 @@ the external name of this procedure will be @code{_ada_hello}. @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node Building Executable Programs with GNAT,GNAT Utility Programs,The GNAT Compilation Model,Top -@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{d7}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{d8} +@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{c4}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{c5} @chapter Building Executable Programs with GNAT This chapter describes first the gnatmake tool -(@ref{1b,,Building with gnatmake}), +(@ref{c6,,Building with gnatmake}), which automatically determines the set of sources needed by an Ada compilation unit and executes the necessary (re)compilations, binding and linking. It also explains how to use each tool individually: the -compiler (gcc, see @ref{1c,,Compiling with gcc}), -binder (gnatbind, see @ref{1d,,Binding with gnatbind}), -and linker (gnatlink, see @ref{1e,,Linking with gnatlink}) +compiler (gcc, see @ref{c7,,Compiling with gcc}), +binder (gnatbind, see @ref{c8,,Binding with gnatbind}), +and linker (gnatlink, see @ref{c9,,Linking with gnatlink}) to build executable programs. Finally, this chapter provides examples of how to make use of the general GNU make mechanism -in a GNAT context (see @ref{1f,,Using the GNU make Utility}). +in a GNAT context (see @ref{70,,Using the GNU make Utility}). @menu @@ -7242,7 +7029,7 @@ in a GNAT context (see @ref{1f,,Using the GNU make Utility}). @end menu @node Building with gnatmake,Compiling with gcc,,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{1b}@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{d9} +@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{c6}@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{ca} @section Building with @code{gnatmake} @@ -7306,7 +7093,7 @@ to @code{gnatmake}. @end menu @node Running gnatmake,Switches for gnatmake,,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{da}@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{db} +@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{cb}@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{cc} @subsection Running @code{gnatmake} @@ -7334,14 +7121,14 @@ be searched for in the specified directory only. Otherwise, the input source file will first be searched in the directory where @code{gnatmake} was invoked and if it is not found, it will be search on the source path of the compiler as described in -@ref{89,,Search Paths and the Run-Time Library (RTL)}. +@ref{73,,Search Paths and the Run-Time Library (RTL)}. All @code{gnatmake} output (except when you specify @code{-M}) is sent to @code{stderr}. The output produced by the @code{-M} switch is sent to @code{stdout}. @node Switches for gnatmake,Mode Switches for gnatmake,Running gnatmake,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{dc}@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{dd} +@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{cd}@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{ce} @subsection Switches for @code{gnatmake} @@ -7715,7 +7502,7 @@ then instead object files and ALI files that already exist are overwritten in place. This means that once a large project is organized into separate directories in the desired manner, then @code{gnatmake} will automatically maintain and update this organization. If no ALI files are found on the -Ada object path (see @ref{89,,Search Paths and the Run-Time Library (RTL)}), +Ada object path (see @ref{73,,Search Paths and the Run-Time Library (RTL)}), the new object and ALI files are created in the directory containing the source being compiled. If another organization is desired, where objects and sources are kept in different directories, @@ -7981,7 +7768,7 @@ Verbosity level High. Equivalent to -v. @item @code{-vP@emph{x}} Indicate the verbosity of the parsing of GNAT project files. -See @ref{de,,Switches Related to Project Files}. +See @ref{cf,,Switches Related to Project Files}. @end table @geindex -x (gnatmake) @@ -8005,7 +7792,7 @@ command line need to be sources of a project file. Indicate that external variable @code{name} has the value @code{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. -@ref{de,,Switches Related to Project Files}. +@ref{cf,,Switches Related to Project Files}. @end table @geindex -z (gnatmake) @@ -8039,7 +7826,7 @@ is passed to @code{gcc} (e.g., @code{-O}, @code{-gnato,} etc.) When looking for source files also look in directory @code{dir}. The order in which source files search is undertaken is -described in @ref{89,,Search Paths and the Run-Time Library (RTL)}. +described in @ref{73,,Search Paths and the Run-Time Library (RTL)}. @end table @geindex -aL (gnatmake) @@ -8071,7 +7858,7 @@ ALI files. When searching for library and object files, look in directory @code{dir}. The order in which library files are searched is described in -@ref{8c,,Search Paths for gnatbind}. +@ref{76,,Search Paths for gnatbind}. @end table @geindex Search paths @@ -8176,7 +7963,7 @@ The selected path is handled like a normal RTS path. @end table @node Mode Switches for gnatmake,Notes on the Command Line,Switches for gnatmake,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat id4}@anchor{df}@anchor{gnat_ugn/building_executable_programs_with_gnat mode-switches-for-gnatmake}@anchor{e0} +@anchor{gnat_ugn/building_executable_programs_with_gnat id4}@anchor{d0}@anchor{gnat_ugn/building_executable_programs_with_gnat mode-switches-for-gnatmake}@anchor{d1} @subsection Mode Switches for @code{gnatmake} @@ -8236,7 +8023,7 @@ or @code{-largs}. @end table @node Notes on the Command Line,How gnatmake Works,Mode Switches for gnatmake,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat id5}@anchor{e1}@anchor{gnat_ugn/building_executable_programs_with_gnat notes-on-the-command-line}@anchor{e2} +@anchor{gnat_ugn/building_executable_programs_with_gnat id5}@anchor{d2}@anchor{gnat_ugn/building_executable_programs_with_gnat notes-on-the-command-line}@anchor{d3} @subsection Notes on the Command Line @@ -8306,7 +8093,7 @@ that the debugging information may be out of date. @end itemize @node How gnatmake Works,Examples of gnatmake Usage,Notes on the Command Line,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{e3}@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{e4} +@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{d4}@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{d5} @subsection How @code{gnatmake} Works @@ -8346,14 +8133,14 @@ When invoking @code{gnatmake} with several @code{file_names}, if a unit is imported by several of the executables, it will be recompiled at most once. Note: when using non-standard naming conventions -(@ref{35,,Using Other File Names}), changing through a configuration pragmas +(@ref{1c,,Using Other File Names}), changing through a configuration pragmas file the version of a source and invoking @code{gnatmake} to recompile may have no effect, if the previous version of the source is still accessible by @code{gnatmake}. It may be necessary to use the switch -f. @node Examples of gnatmake Usage,,How gnatmake Works,Building with gnatmake -@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatmake-usage}@anchor{e5}@anchor{gnat_ugn/building_executable_programs_with_gnat id7}@anchor{e6} +@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatmake-usage}@anchor{d6}@anchor{gnat_ugn/building_executable_programs_with_gnat id7}@anchor{d7} @subsection Examples of @code{gnatmake} Usage @@ -8385,7 +8172,7 @@ displaying commands it is executing. @end table @node Compiling with gcc,Compiler Switches,Building with gnatmake,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-with-gcc}@anchor{1c}@anchor{gnat_ugn/building_executable_programs_with_gnat id8}@anchor{e7} +@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-with-gcc}@anchor{c7}@anchor{gnat_ugn/building_executable_programs_with_gnat id8}@anchor{d8} @section Compiling with @code{gcc} @@ -8402,7 +8189,7 @@ that can be used to control the behavior of the compiler. @end menu @node Compiling Programs,Search Paths and the Run-Time Library RTL,,Compiling with gcc -@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-programs}@anchor{e8}@anchor{gnat_ugn/building_executable_programs_with_gnat id9}@anchor{e9} +@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-programs}@anchor{d9}@anchor{gnat_ugn/building_executable_programs_with_gnat id9}@anchor{da} @subsection Compiling Programs @@ -8515,11 +8302,11 @@ calls @code{gnat1} (the Ada compiler) twice to compile @code{x.adb} and The compiler generates two object files @code{x.o} and @code{y.o} and the two ALI files @code{x.ali} and @code{y.ali}. -Any switches apply to all the files listed, see @ref{ea,,Compiler Switches} for a +Any switches apply to all the files listed, see @ref{db,,Compiler Switches} for a list of available @code{gcc} switches. @node Search Paths and the Run-Time Library RTL,Order of Compilation Issues,Compiling Programs,Compiling with gcc -@anchor{gnat_ugn/building_executable_programs_with_gnat id10}@anchor{eb}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-and-the-run-time-library-rtl}@anchor{89} +@anchor{gnat_ugn/building_executable_programs_with_gnat id10}@anchor{dc}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-and-the-run-time-library-rtl}@anchor{73} @subsection Search Paths and the Run-Time Library (RTL) @@ -8576,7 +8363,7 @@ names separated by colons (semicolons when working with the NT version). The content of the @code{ada_source_path} file which is part of the GNAT installation tree and is used to store standard libraries such as the GNAT Run Time Library (RTL) source files. -@ref{87,,Installing a library} +@ref{71,,Installing a library} @end itemize Specifying the switch @code{-I-} @@ -8618,7 +8405,7 @@ in compiling sources from multiple directories. This can make development environments much more flexible. @node Order of Compilation Issues,Examples,Search Paths and the Run-Time Library RTL,Compiling with gcc -@anchor{gnat_ugn/building_executable_programs_with_gnat id11}@anchor{ec}@anchor{gnat_ugn/building_executable_programs_with_gnat order-of-compilation-issues}@anchor{ed} +@anchor{gnat_ugn/building_executable_programs_with_gnat id11}@anchor{dd}@anchor{gnat_ugn/building_executable_programs_with_gnat order-of-compilation-issues}@anchor{de} @subsection Order of Compilation Issues @@ -8646,7 +8433,7 @@ source files on which it depends. @item There is no library as such, apart from the ALI files -(@ref{42,,The Ada Library Information Files}, for information on the format +(@ref{28,,The Ada Library Information Files}, for information on the format of these files). For now we find it convenient to create separate ALI files, but eventually the information therein may be incorporated into the object file directly. @@ -8659,7 +8446,7 @@ described above), or you will receive a fatal error message. @end itemize @node Examples,,Order of Compilation Issues,Compiling with gcc -@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{ee}@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{ef} +@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{df}@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{e0} @subsection Examples @@ -8687,7 +8474,7 @@ Compile the subunit in file @code{abc-def.adb} in semantic-checking-only mode. @node Compiler Switches,Linker Switches,Compiling with gcc,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat compiler-switches}@anchor{f0}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gcc}@anchor{ea} +@anchor{gnat_ugn/building_executable_programs_with_gnat compiler-switches}@anchor{e1}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gcc}@anchor{db} @section Compiler Switches @@ -8726,7 +8513,7 @@ compilation units. @end menu @node Alphabetical List of All Switches,Output and Error Message Control,,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{f1}@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{f2} +@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{e2}@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{e3} @subsection Alphabetical List of All Switches @@ -8911,7 +8698,7 @@ and thus producing inferior code. Causes the compiler to avoid assumptions regarding non-aliasing of objects of different types. See -@ref{f3,,Optimization and Strict Aliasing} for details. +@ref{e4,,Optimization and Strict Aliasing} for details. @end table @geindex -fno-strict-overflow (gcc) @@ -8937,7 +8724,7 @@ for very peculiar cases of low-level programming. @item @code{-fstack-check} Activates stack checking. -See @ref{f4,,Stack Overflow Checking} for details. +See @ref{e5,,Stack Overflow Checking} for details. @end table @geindex -fstack-usage (gcc) @@ -8948,7 +8735,7 @@ See @ref{f4,,Stack Overflow Checking} for details. @item @code{-fstack-usage} Makes the compiler output stack usage information for the program, on a -per-subprogram basis. See @ref{f5,,Static Stack Usage Analysis} for details. +per-subprogram basis. See @ref{e6,,Static Stack Usage Analysis} for details. @end table @geindex -g (gcc) @@ -9078,7 +8865,7 @@ Generate brief messages to @code{stderr} even if verbose mode set. @item @code{-gnatB} Assume no invalid (bad) values except for 'Valid attribute use -(@ref{f6,,Validity Checking}). +(@ref{e7,,Validity Checking}). @end table @geindex -gnatc (gcc) @@ -9191,7 +8978,7 @@ not share the memory location of @code{Obj}. Specify a configuration pragma file (the equal sign is optional) -(@ref{79,,The Configuration Pragmas Files}). +(@ref{62,,The Configuration Pragmas Files}). @end table @geindex -gnateC (gcc) @@ -9224,7 +9011,7 @@ Disable atomic synchronization @item @code{-gnateDsymbol[=@emph{value}]} Defines a symbol, associated with @code{value}, for preprocessing. -(@ref{18,,Integrated Preprocessing}). +(@ref{90,,Integrated Preprocessing}). @end table @geindex -gnateE (gcc) @@ -9273,7 +9060,7 @@ for unconstrained predefined types. See description of pragma The @code{-gnatc} switch must always be specified before this switch, e.g. @code{-gnatceg}. Generate a C header from the Ada input file. See -@ref{ca,,Generating C Headers for Ada Specifications} for more +@ref{b7,,Generating C Headers for Ada Specifications} for more information. @end quotation @@ -9347,7 +9134,7 @@ This switch turns off the info messages about implicit elaboration pragmas. Specify a mapping file (the equal sign is optional) -(@ref{f7,,Units to Sources Mapping Files}). +(@ref{e8,,Units to Sources Mapping Files}). @end table @geindex -gnatep (gcc) @@ -9359,7 +9146,7 @@ Specify a mapping file Specify a preprocessing data file (the equal sign is optional) -(@ref{18,,Integrated Preprocessing}). +(@ref{90,,Integrated Preprocessing}). @end table @geindex -gnateP (gcc) @@ -9557,7 +9344,7 @@ support this switch. @item @code{-gnateV} Check that all actual parameters of a subprogram call are valid according to -the rules of validity checking (@ref{f6,,Validity Checking}). +the rules of validity checking (@ref{e7,,Validity Checking}). @end table @geindex -gnateY (gcc) @@ -9661,7 +9448,7 @@ For further details see @ref{f,,Elaboration Order Handling in GNAT}. Identifier character set (@code{c} = 1/2/3/4/8/9/p/f/n/w). For details of the possible selections for @code{c}, -see @ref{48,,Character Set Control}. +see @ref{31,,Character Set Control}. @end table @geindex -gnatI (gcc) @@ -9910,7 +9697,7 @@ overflow checking is enabled. Note that division by zero is a separate check that is not controlled by this switch (divide-by-zero checking is on by default). -See also @ref{f8,,Specifying the Desired Mode}. +See also @ref{e9,,Specifying the Desired Mode}. @end table @geindex -gnatp (gcc) @@ -9920,7 +9707,7 @@ See also @ref{f8,,Specifying the Desired Mode}. @item @code{-gnatp} -Suppress all checks. See @ref{f9,,Run-Time Checks} for details. This switch +Suppress all checks. See @ref{ea,,Run-Time Checks} for details. This switch has no effect if cancelled by a subsequent @code{-gnat-p} switch. @end table @@ -10059,7 +9846,7 @@ Verbose mode. Full error output with source lines to @code{stdout}. @item @code{-gnatV} -Control level of validity checking (@ref{f6,,Validity Checking}). +Control level of validity checking (@ref{e7,,Validity Checking}). @end table @geindex -gnatw (gcc) @@ -10072,7 +9859,7 @@ Control level of validity checking (@ref{f6,,Validity Checking}). Warning mode where @code{xxx} is a string of option letters that denotes the exact warnings that -are enabled or disabled (@ref{fa,,Warning Message Control}). +are enabled or disabled (@ref{eb,,Warning Message Control}). @end table @geindex -gnatW (gcc) @@ -10113,7 +9900,7 @@ Enable GNAT implementation extensions and latest Ada version. @item @code{-gnaty} -Enable built-in style checks (@ref{fb,,Style Checking}). +Enable built-in style checks (@ref{ec,,Style Checking}). @end table @geindex -gnatz (gcc) @@ -10138,7 +9925,7 @@ Distribution stub generation and compilation Direct GNAT to search the @code{dir} directory for source files needed by the current compilation -(see @ref{89,,Search Paths and the Run-Time Library (RTL)}). +(see @ref{73,,Search Paths and the Run-Time Library (RTL)}). @end table @geindex -I- (gcc) @@ -10152,7 +9939,7 @@ the current compilation Except for the source file named in the command line, do not look for source files in the directory containing the source file named in the command line -(see @ref{89,,Search Paths and the Run-Time Library (RTL)}). +(see @ref{73,,Search Paths and the Run-Time Library (RTL)}). @end table @geindex -o (gcc) @@ -10256,7 +10043,7 @@ Optimize space usage @end multitable -See also @ref{fc,,Optimization Levels}. +See also @ref{ed,,Optimization Levels}. @end table @geindex -pass-exit-codes (gcc) @@ -10278,7 +10065,7 @@ exit status. @item @code{--RTS=@emph{rts-path}} Specifies the default location of the run-time library. Same meaning as the -equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}). +equivalent @code{gnatmake} flag (@ref{cd,,Switches for gnatmake}). @end table @geindex -S (gcc) @@ -10404,7 +10191,7 @@ as warning mode modifiers (see description of @code{-gnatw}). @item Once a 'V' appears in the string (that is a use of the @code{-gnatV} switch), then all further characters in the switch are interpreted -as validity checking options (@ref{f6,,Validity Checking}). +as validity checking options (@ref{e7,,Validity Checking}). @item Option 'em', 'ec', 'ep', 'l=' and 'R' must be the last options in @@ -10412,7 +10199,7 @@ a combined list of options. @end itemize @node Output and Error Message Control,Warning Message Control,Alphabetical List of All Switches,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id14}@anchor{fd}@anchor{gnat_ugn/building_executable_programs_with_gnat output-and-error-message-control}@anchor{fe} +@anchor{gnat_ugn/building_executable_programs_with_gnat id14}@anchor{ee}@anchor{gnat_ugn/building_executable_programs_with_gnat output-and-error-message-control}@anchor{ef} @subsection Output and Error Message Control @@ -10707,7 +10494,7 @@ since ALI files are never generated if @code{-gnats} is set. @end table @node Warning Message Control,Debugging and Assertion Control,Output and Error Message Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{fa}@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{ff} +@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{eb}@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{f0} @subsection Warning Message Control @@ -12812,7 +12599,7 @@ used in conjunction with an optimization level greater than zero. @item @code{-Wstack-usage=@emph{len}} Warn if the stack usage of a subprogram might be larger than @code{len} bytes. -See @ref{f5,,Static Stack Usage Analysis} for details. +See @ref{e6,,Static Stack Usage Analysis} for details. @end table @geindex -Wall (gcc) @@ -13010,7 +12797,7 @@ When no switch @code{-gnatw} is used, this is equivalent to: @end quotation @node Debugging and Assertion Control,Validity Checking,Warning Message Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-and-assertion-control}@anchor{100}@anchor{gnat_ugn/building_executable_programs_with_gnat id16}@anchor{101} +@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-and-assertion-control}@anchor{f1}@anchor{gnat_ugn/building_executable_programs_with_gnat id16}@anchor{f2} @subsection Debugging and Assertion Control @@ -13099,7 +12886,7 @@ is @code{False}, the exception @code{Assert_Failure} is raised. @end table @node Validity Checking,Style Checking,Debugging and Assertion Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{f6}@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{102} +@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{e7}@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{f3} @subsection Validity Checking @@ -13388,7 +13175,7 @@ the validity checking mode at the program source level, and also allows for temporary disabling of validity checks. @node Style Checking,Run-Time Checks,Validity Checking,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id18}@anchor{103}@anchor{gnat_ugn/building_executable_programs_with_gnat style-checking}@anchor{fb} +@anchor{gnat_ugn/building_executable_programs_with_gnat id18}@anchor{f4}@anchor{gnat_ugn/building_executable_programs_with_gnat style-checking}@anchor{ec} @subsection Style Checking @@ -14110,7 +13897,7 @@ built-in standard style check options are enabled. The switch @code{-gnatyN} clears any previously set style checks. @node Run-Time Checks,Using gcc for Syntax Checking,Style Checking,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{f9}@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{104} +@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{ea}@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{f5} @subsection Run-Time Checks @@ -14304,7 +14091,7 @@ on subprogram calls and generic instantiations. Note that @code{-gnatE} is not necessary for safety, because in the default mode, GNAT ensures statically that the checks would not fail. For full details of the effect and use of this switch, -@ref{1c,,Compiling with gcc}. +@ref{c7,,Compiling with gcc}. @end table @geindex -fstack-check (gcc) @@ -14320,7 +14107,7 @@ For full details of the effect and use of this switch, @item @code{-fstack-check} Activates stack overflow checking. For full details of the effect and use of -this switch see @ref{f4,,Stack Overflow Checking}. +this switch see @ref{e5,,Stack Overflow Checking}. @end table @geindex Unsuppress @@ -14331,7 +14118,7 @@ checks) or @code{Unsuppress} (to add back suppressed checks) pragmas in the program source. @node Using gcc for Syntax Checking,Using gcc for Semantic Checking,Run-Time Checks,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id20}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-syntax-checking}@anchor{106} +@anchor{gnat_ugn/building_executable_programs_with_gnat id20}@anchor{f6}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-syntax-checking}@anchor{f7} @subsection Using @code{gcc} for Syntax Checking @@ -14384,11 +14171,11 @@ Normally, GNAT allows only a single unit in a source file. However, this restriction does not apply in syntax-check-only mode, and it is possible to check a file containing multiple compilation units concatenated together. This is primarily used by the @code{gnatchop} utility -(@ref{36,,Renaming Files with gnatchop}). +(@ref{1d,,Renaming Files with gnatchop}). @end table @node Using gcc for Semantic Checking,Compiling Different Versions of Ada,Using gcc for Syntax Checking,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id21}@anchor{107}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-semantic-checking}@anchor{108} +@anchor{gnat_ugn/building_executable_programs_with_gnat id21}@anchor{f8}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-semantic-checking}@anchor{f9} @subsection Using @code{gcc} for Semantic Checking @@ -14413,13 +14200,13 @@ semantic restrictions on file structuring to operate in this mode: @item The needed source files must be accessible -(see @ref{89,,Search Paths and the Run-Time Library (RTL)}). +(see @ref{73,,Search Paths and the Run-Time Library (RTL)}). @item Each file must contain only one compilation unit. @item -The file name and unit name must match (@ref{52,,File Naming Rules}). +The file name and unit name must match (@ref{3b,,File Naming Rules}). @end itemize The output consists of error messages as appropriate. No object file is @@ -14435,7 +14222,7 @@ and specifications where a separate body is present). @end table @node Compiling Different Versions of Ada,Character Set Control,Using gcc for Semantic Checking,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-different-versions-of-ada}@anchor{6}@anchor{gnat_ugn/building_executable_programs_with_gnat id22}@anchor{109} +@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-different-versions-of-ada}@anchor{6}@anchor{gnat_ugn/building_executable_programs_with_gnat id22}@anchor{fa} @subsection Compiling Different Versions of Ada @@ -14569,7 +14356,7 @@ extensions, see the GNAT reference manual. @end table @node Character Set Control,File Naming Control,Compiling Different Versions of Ada,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{48} +@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{fb}@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{31} @subsection Character Set Control @@ -14680,7 +14467,7 @@ allowed in identifiers @end multitable -See @ref{3e,,Foreign Language Representation} for full details on the +See @ref{23,,Foreign Language Representation} for full details on the implementation of these character sets. @end table @@ -14748,7 +14535,7 @@ Brackets encoding only (default value) For full details on these encoding -methods see @ref{4e,,Wide_Character Encodings}. +methods see @ref{37,,Wide_Character Encodings}. Note that brackets coding is always accepted, even if one of the other options is specified, so for example @code{-gnatW8} specifies that both brackets and UTF-8 encodings will be recognized. The units that are @@ -14796,7 +14583,7 @@ comments are ended by an appropriate (CR, or CR/LF, or LF) line terminator. This is a common mode for many programs with foreign language comments. @node File Naming Control,Subprogram Inlining Control,Character Set Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat file-naming-control}@anchor{10b}@anchor{gnat_ugn/building_executable_programs_with_gnat id24}@anchor{10c} +@anchor{gnat_ugn/building_executable_programs_with_gnat file-naming-control}@anchor{fc}@anchor{gnat_ugn/building_executable_programs_with_gnat id24}@anchor{fd} @subsection File Naming Control @@ -14812,11 +14599,11 @@ Activates file name 'krunching'. @code{n}, a decimal integer in the range including the @code{.ads} or @code{.adb} extension). The default is not to enable file name krunching. -For the source file naming rules, @ref{52,,File Naming Rules}. +For the source file naming rules, @ref{3b,,File Naming Rules}. @end table @node Subprogram Inlining Control,Auxiliary Output Control,File Naming Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{10e} +@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{fe}@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{ff} @subsection Subprogram Inlining Control @@ -14849,7 +14636,7 @@ If you specify this switch the compiler will access these bodies, creating an extra source dependency for the resulting object file, and where possible, the call will be inlined. For further details on when inlining is possible -see @ref{10f,,Inlining of Subprograms}. +see @ref{100,,Inlining of Subprograms}. @end table @geindex -gnatN (gcc) @@ -14870,7 +14657,7 @@ inlining, but that is no longer the case. @end table @node Auxiliary Output Control,Debugging Control,Subprogram Inlining Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat auxiliary-output-control}@anchor{110}@anchor{gnat_ugn/building_executable_programs_with_gnat id26}@anchor{111} +@anchor{gnat_ugn/building_executable_programs_with_gnat auxiliary-output-control}@anchor{101}@anchor{gnat_ugn/building_executable_programs_with_gnat id26}@anchor{102} @subsection Auxiliary Output Control @@ -14940,7 +14727,7 @@ An object file has been generated for every source file. @end table @node Debugging Control,Exception Handling Control,Auxiliary Output Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-control}@anchor{112}@anchor{gnat_ugn/building_executable_programs_with_gnat id27}@anchor{113} +@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-control}@anchor{103}@anchor{gnat_ugn/building_executable_programs_with_gnat id27}@anchor{104} @subsection Debugging Control @@ -15289,7 +15076,7 @@ encodings for the rest. @end table @node Exception Handling Control,Units to Sources Mapping Files,Debugging Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{114}@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{115} +@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{106} @subsection Exception Handling Control @@ -15357,11 +15144,11 @@ is available for the target in use, otherwise it will generate an error. The same option @code{--RTS} must be used both for @code{gcc} and @code{gnatbind}. Passing this option to @code{gnatmake} -(@ref{dc,,Switches for gnatmake}) will ensure the required consistency +(@ref{cd,,Switches for gnatmake}) will ensure the required consistency through the compilation and binding steps. @node Units to Sources Mapping Files,Code Generation Control,Exception Handling Control,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat id29}@anchor{116}@anchor{gnat_ugn/building_executable_programs_with_gnat units-to-sources-mapping-files}@anchor{f7} +@anchor{gnat_ugn/building_executable_programs_with_gnat id29}@anchor{107}@anchor{gnat_ugn/building_executable_programs_with_gnat units-to-sources-mapping-files}@anchor{e8} @subsection Units to Sources Mapping Files @@ -15413,7 +15200,7 @@ mapping file and communicates it to the compiler using this switch. @end table @node Code Generation Control,,Units to Sources Mapping Files,Compiler Switches -@anchor{gnat_ugn/building_executable_programs_with_gnat code-generation-control}@anchor{117}@anchor{gnat_ugn/building_executable_programs_with_gnat id30}@anchor{118} +@anchor{gnat_ugn/building_executable_programs_with_gnat code-generation-control}@anchor{108}@anchor{gnat_ugn/building_executable_programs_with_gnat id30}@anchor{109} @subsection Code Generation Control @@ -15442,7 +15229,7 @@ there is no point in using @code{-m} switches to improve performance unless you actually see a performance improvement. @node Linker Switches,Binding with gnatbind,Compiler Switches,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat linker-switches}@anchor{119}@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{11a} +@anchor{gnat_ugn/building_executable_programs_with_gnat linker-switches}@anchor{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{10b} @section Linker Switches @@ -15462,7 +15249,7 @@ platforms. @end table @node Binding with gnatbind,Linking with gnatlink,Linker Switches,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-gnatbind}@anchor{1d}@anchor{gnat_ugn/building_executable_programs_with_gnat id32}@anchor{11b} +@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-gnatbind}@anchor{c8}@anchor{gnat_ugn/building_executable_programs_with_gnat id32}@anchor{10c} @section Binding with @code{gnatbind} @@ -15513,7 +15300,7 @@ to be read by the @code{gnatlink} utility used to link the Ada application. @end menu @node Running gnatbind,Switches for gnatbind,,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{11c}@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{11d} +@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{10e} @subsection Running @code{gnatbind} @@ -15598,7 +15385,7 @@ Ada code provided the @code{-g} switch is used for @code{gnatbind} and @code{gnatlink}. @node Switches for gnatbind,Command-Line Access,Running gnatbind,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id34}@anchor{11e}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatbind}@anchor{11f} +@anchor{gnat_ugn/building_executable_programs_with_gnat id34}@anchor{10f}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatbind}@anchor{110} @subsection Switches for @code{gnatbind} @@ -15793,7 +15580,7 @@ Currently the same as @code{-Ea}. @item @code{-f@emph{elab-order}} -Force elaboration order. For further details see @ref{120,,Elaboration Control} +Force elaboration order. For further details see @ref{111,,Elaboration Control} and @ref{f,,Elaboration Order Handling in GNAT}. @end table @@ -15842,7 +15629,7 @@ Legacy elaboration order model enabled. For further details see @item @code{-H32} Use 32-bit allocations for @code{__gnat_malloc} (and thus for access types). -For further details see @ref{121,,Dynamic Allocation Control}. +For further details see @ref{112,,Dynamic Allocation Control}. @end table @geindex -H64 (gnatbind) @@ -15855,7 +15642,7 @@ For further details see @ref{121,,Dynamic Allocation Control}. @item @code{-H64} Use 64-bit allocations for @code{__gnat_malloc} (and thus for access types). -For further details see @ref{121,,Dynamic Allocation Control}. +For further details see @ref{112,,Dynamic Allocation Control}. @geindex -I (gnatbind) @@ -15882,11 +15669,11 @@ Output chosen elaboration order. @item @code{-L@emph{xxx}} Bind the units for library building. In this case the @code{adainit} and -@code{adafinal} procedures (@ref{b4,,Binding with Non-Ada Main Programs}) +@code{adafinal} procedures (@ref{a0,,Binding with Non-Ada Main Programs}) are renamed to @code{@emph{xxx}init} and @code{@emph{xxx}final}. Implies -n. -(@ref{15,,GNAT and Libraries}, for more details.) +(@ref{2a,,GNAT and Libraries}, for more details.) @geindex -M (gnatbind) @@ -15953,7 +15740,7 @@ Do not look for library files in the system default directory. @item @code{--RTS=@emph{rts-path}} Specifies the default location of the run-time library. Same meaning as the -equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}). +equivalent @code{gnatmake} flag (@ref{cd,,Switches for gnatmake}). @geindex -o (gnatbind) @@ -16107,7 +15894,7 @@ Enable dynamic stack usage, with @code{n} results stored and displayed at program termination. A result is generated when a task terminates. Results that can't be stored are displayed on the fly, at task termination. This option is currently not supported on Itanium -platforms. (See @ref{122,,Dynamic Stack Usage Analysis} for details.) +platforms. (See @ref{113,,Dynamic Stack Usage Analysis} for details.) @geindex -v (gnatbind) @@ -16184,7 +15971,7 @@ no arguments. @end menu @node Consistency-Checking Modes,Binder Error Message Control,,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{123}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{124} +@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{114}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{115} @subsubsection Consistency-Checking Modes @@ -16238,7 +16025,7 @@ case the checking against sources has already been performed by @end table @node Binder Error Message Control,Elaboration Control,Consistency-Checking Modes,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{125}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{126} +@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{116}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{117} @subsubsection Binder Error Message Control @@ -16348,7 +16135,7 @@ with extreme care. @end table @node Elaboration Control,Output Control,Binder Error Message Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{127}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{120} +@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{118}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{111} @subsubsection Elaboration Control @@ -16433,7 +16220,7 @@ debugging/experimental use. @end table @node Output Control,Dynamic Allocation Control,Elaboration Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{128}@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{129} +@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{119}@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{11a} @subsubsection Output Control @@ -16514,7 +16301,7 @@ be used to improve code generation in some cases. @end table @node Dynamic Allocation Control,Binding with Non-Ada Main Programs,Output Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{121}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{12a} +@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{112}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{11b} @subsubsection Dynamic Allocation Control @@ -16540,7 +16327,7 @@ unless explicitly overridden by a @code{'Size} clause on the access type. These switches are only effective on VMS platforms. @node Binding with Non-Ada Main Programs,Binding Programs with No Main Subprogram,Dynamic Allocation Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-non-ada-main-programs}@anchor{b4}@anchor{gnat_ugn/building_executable_programs_with_gnat id40}@anchor{12b} +@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-non-ada-main-programs}@anchor{a0}@anchor{gnat_ugn/building_executable_programs_with_gnat id40}@anchor{11c} @subsubsection Binding with Non-Ada Main Programs @@ -16549,7 +16336,7 @@ program is in Ada, and that the task of the binder is to generate a corresponding function @code{main} that invokes this Ada main program. GNAT also supports the building of executable programs where the main program is not in Ada, but some of the called routines are -written in Ada and compiled using GNAT (@ref{44,,Mixed Language Programming}). +written in Ada and compiled using GNAT (@ref{2c,,Mixed Language Programming}). The following switch is used in this situation: @quotation @@ -16636,7 +16423,7 @@ side effect is that this could be the wrong mode for the foreign code where floating point computation could be broken after this call. @node Binding Programs with No Main Subprogram,,Binding with Non-Ada Main Programs,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat binding-programs-with-no-main-subprogram}@anchor{12c}@anchor{gnat_ugn/building_executable_programs_with_gnat id41}@anchor{12d} +@anchor{gnat_ugn/building_executable_programs_with_gnat binding-programs-with-no-main-subprogram}@anchor{11d}@anchor{gnat_ugn/building_executable_programs_with_gnat id41}@anchor{11e} @subsubsection Binding Programs with No Main Subprogram @@ -16667,7 +16454,7 @@ the binder switch @end table @node Command-Line Access,Search Paths for gnatbind,Switches for gnatbind,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{12e}@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{12f} +@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{11f}@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{120} @subsection Command-Line Access @@ -16697,7 +16484,7 @@ required, your main program must set @code{gnat_argc} and it. @node Search Paths for gnatbind,Examples of gnatbind Usage,Command-Line Access,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{8c}@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{130} +@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{76}@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{121} @subsection Search Paths for @code{gnatbind} @@ -16705,7 +16492,7 @@ The binder takes the name of an ALI file as its argument and needs to locate source files as well as other ALI files to verify object consistency. For source files, it follows exactly the same search rules as @code{gcc} -(see @ref{89,,Search Paths and the Run-Time Library (RTL)}). For ALI files the +(see @ref{73,,Search Paths and the Run-Time Library (RTL)}). For ALI files the directories searched are: @@ -16754,7 +16541,7 @@ of GNAT). The content of the @code{ada_object_path} file which is part of the GNAT installation tree and is used to store standard libraries such as the GNAT Run-Time Library (RTL) unless the switch @code{-nostdlib} is -specified. See @ref{87,,Installing a library} +specified. See @ref{71,,Installing a library} @end itemize @geindex -I (gnatbind) @@ -16801,7 +16588,7 @@ in compiling sources from multiple directories. This can make development environments much more flexible. @node Examples of gnatbind Usage,,Search Paths for gnatbind,Binding with gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{131}@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{132} +@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{122}@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{123} @subsection Examples of @code{gnatbind} Usage @@ -16830,7 +16617,7 @@ since gnatlink will not be able to find the generated file. @end quotation @node Linking with gnatlink,Using the GNU make Utility,Binding with gnatbind,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat id45}@anchor{133}@anchor{gnat_ugn/building_executable_programs_with_gnat linking-with-gnatlink}@anchor{1e} +@anchor{gnat_ugn/building_executable_programs_with_gnat id45}@anchor{124}@anchor{gnat_ugn/building_executable_programs_with_gnat linking-with-gnatlink}@anchor{c9} @section Linking with @code{gnatlink} @@ -16851,7 +16638,7 @@ generated by the @code{gnatbind} to determine this list. @end menu @node Running gnatlink,Switches for gnatlink,,Linking with gnatlink -@anchor{gnat_ugn/building_executable_programs_with_gnat id46}@anchor{134}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatlink}@anchor{135} +@anchor{gnat_ugn/building_executable_programs_with_gnat id46}@anchor{125}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatlink}@anchor{126} @subsection Running @code{gnatlink} @@ -16910,8 +16697,8 @@ $ gnatlink my_prog -Wl,-Map,MAPFILE Using @code{linker options} it is possible to set the program stack and heap size. -See @ref{136,,Setting Stack Size from gnatlink} and -@ref{137,,Setting Heap Size from gnatlink}. +See @ref{127,,Setting Stack Size from gnatlink} and +@ref{128,,Setting Heap Size from gnatlink}. @code{gnatlink} determines the list of objects required by the Ada program and prepends them to the list of objects passed to the linker. @@ -16920,7 +16707,7 @@ program and prepends them to the list of objects passed to the linker. presented to the linker. @node Switches for gnatlink,,Running gnatlink,Linking with gnatlink -@anchor{gnat_ugn/building_executable_programs_with_gnat id47}@anchor{138}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatlink}@anchor{139} +@anchor{gnat_ugn/building_executable_programs_with_gnat id47}@anchor{129}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatlink}@anchor{12a} @subsection Switches for @code{gnatlink} @@ -17115,7 +16902,7 @@ switch. @end table @node Using the GNU make Utility,,Linking with gnatlink,Building Executable Programs with GNAT -@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{1f}@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{13a} +@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{70}@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{12b} @section Using the GNU @code{make} Utility @@ -17124,7 +16911,7 @@ switch. This chapter offers some examples of makefiles that solve specific problems. It does not explain how to write a makefile, nor does it try to replace the -@code{gnatmake} utility (@ref{1b,,Building with gnatmake}). +@code{gnatmake} utility (@ref{c6,,Building with gnatmake}). All the examples in this section are specific to the GNU version of make. Although @code{make} is a standard utility, and the basic language @@ -17140,7 +16927,7 @@ is the same, these examples use some advanced features found only in @end menu @node Using gnatmake in a Makefile,Automatically Creating a List of Directories,,Using the GNU make Utility -@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{13b}@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{13c} +@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{12c}@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{12d} @subsection Using gnatmake in a Makefile @@ -17159,7 +16946,7 @@ the appropriate directories. Note that you should also read the example on how to automatically create the list of directories -(@ref{13d,,Automatically Creating a List of Directories}) +(@ref{12e,,Automatically Creating a List of Directories}) which might help you in case your project has a lot of subdirectories. @example @@ -17239,7 +17026,7 @@ clean:: @end example @node Automatically Creating a List of Directories,Generating the Command Line Switches,Using gnatmake in a Makefile,Using the GNU make Utility -@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{13e}@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{13d} +@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{12f}@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{12e} @subsection Automatically Creating a List of Directories @@ -17312,12 +17099,12 @@ DIRS := $@{shell find $@{ROOT_DIRECTORY@} -type d -print@} @end example @node Generating the Command Line Switches,Overcoming Command Line Length Limits,Automatically Creating a List of Directories,Using the GNU make Utility -@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{13f}@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{140} +@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{130}@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{131} @subsection Generating the Command Line Switches Once you have created the list of directories as explained in the -previous section (@ref{13d,,Automatically Creating a List of Directories}), +previous section (@ref{12e,,Automatically Creating a List of Directories}), you can easily generate the command line arguments to pass to gnatmake. For the sake of completeness, this example assumes that the source path @@ -17338,7 +17125,7 @@ all: @end example @node Overcoming Command Line Length Limits,,Generating the Command Line Switches,Using the GNU make Utility -@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{141}@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{142} +@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{132}@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{133} @subsection Overcoming Command Line Length Limits @@ -17353,7 +17140,7 @@ even none on most systems). It assumes that you have created a list of directories in your Makefile, using one of the methods presented in -@ref{13d,,Automatically Creating a List of Directories}. +@ref{12e,,Automatically Creating a List of Directories}. For the sake of completeness, we assume that the object path (where the ALI files are found) is different from the sources patch. @@ -17396,7 +17183,7 @@ all: @end example @node GNAT Utility Programs,GNAT and Program Execution,Building Executable Programs with GNAT,Top -@anchor{gnat_ugn/gnat_utility_programs doc}@anchor{143}@anchor{gnat_ugn/gnat_utility_programs gnat-utility-programs}@anchor{b}@anchor{gnat_ugn/gnat_utility_programs id1}@anchor{144} +@anchor{gnat_ugn/gnat_utility_programs doc}@anchor{134}@anchor{gnat_ugn/gnat_utility_programs gnat-utility-programs}@anchor{b}@anchor{gnat_ugn/gnat_utility_programs id1}@anchor{135} @chapter GNAT Utility Programs @@ -17407,16 +17194,10 @@ This chapter describes a number of utility programs: @itemize * @item -@ref{20,,The File Cleanup Utility gnatclean} - -@item -@ref{21,,The GNAT Library Browser gnatls} +@ref{136,,The File Cleanup Utility gnatclean} @item -@ref{22,,The Cross-Referencing Tools gnatxref and gnatfind} - -@item -@ref{23,,The Ada to HTML Converter gnathtml} +@ref{137,,The GNAT Library Browser gnatls} @end itemize Other GNAT utilities are described elsewhere in this manual: @@ -17425,28 +17206,26 @@ Other GNAT utilities are described elsewhere in this manual: @itemize * @item -@ref{59,,Handling Arbitrary File Naming Conventions with gnatname} +@ref{42,,Handling Arbitrary File Naming Conventions with gnatname} @item -@ref{63,,File Name Krunching with gnatkr} +@ref{4c,,File Name Krunching with gnatkr} @item -@ref{36,,Renaming Files with gnatchop} +@ref{1d,,Renaming Files with gnatchop} @item -@ref{17,,Preprocessing with gnatprep} +@ref{8f,,Preprocessing with gnatprep} @end itemize @menu * The File Cleanup Utility gnatclean:: * The GNAT Library Browser gnatls:: -* The Cross-Referencing Tools gnatxref and gnatfind:: -* The Ada to HTML Converter gnathtml:: @end menu @node The File Cleanup Utility gnatclean,The GNAT Library Browser gnatls,,GNAT Utility Programs -@anchor{gnat_ugn/gnat_utility_programs id2}@anchor{145}@anchor{gnat_ugn/gnat_utility_programs the-file-cleanup-utility-gnatclean}@anchor{20} +@anchor{gnat_ugn/gnat_utility_programs id2}@anchor{138}@anchor{gnat_ugn/gnat_utility_programs the-file-cleanup-utility-gnatclean}@anchor{136} @section The File Cleanup Utility @code{gnatclean} @@ -17466,7 +17245,7 @@ generated files and executable files. @end menu @node Running gnatclean,Switches for gnatclean,,The File Cleanup Utility gnatclean -@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{146}@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{147} +@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{139}@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{13a} @subsection Running @code{gnatclean} @@ -17490,7 +17269,7 @@ the linker. In informative-only mode, specified by switch normal mode is listed, but no file is actually deleted. @node Switches for gnatclean,,Running gnatclean,The File Cleanup Utility gnatclean -@anchor{gnat_ugn/gnat_utility_programs id4}@anchor{148}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatclean}@anchor{149} +@anchor{gnat_ugn/gnat_utility_programs id4}@anchor{13b}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatclean}@anchor{13c} @subsection Switches for @code{gnatclean} @@ -17641,7 +17420,7 @@ Verbose mode. @item @code{-vP@emph{x}} Indicates the verbosity of the parsing of GNAT project files. -@ref{de,,Switches Related to Project Files}. +@ref{cf,,Switches Related to Project Files}. @end table @geindex -X (gnatclean) @@ -17654,7 +17433,7 @@ Indicates the verbosity of the parsing of GNAT project files. Indicates that external variable @code{name} has the value @code{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. -See @ref{de,,Switches Related to Project Files}. +See @ref{cf,,Switches Related to Project Files}. @end table @geindex -aO (gnatclean) @@ -17691,8 +17470,8 @@ Do not look for ALI or object files in the directory where @code{gnatclean} was invoked. @end table -@node The GNAT Library Browser gnatls,The Cross-Referencing Tools gnatxref and gnatfind,The File Cleanup Utility gnatclean,GNAT Utility Programs -@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{21}@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{14a} +@node The GNAT Library Browser gnatls,,The File Cleanup Utility gnatclean,GNAT Utility Programs +@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{137}@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{13d} @section The GNAT Library Browser @code{gnatls} @@ -17713,7 +17492,7 @@ as well as various characteristics. @end menu @node Running gnatls,Switches for gnatls,,The GNAT Library Browser gnatls -@anchor{gnat_ugn/gnat_utility_programs id6}@anchor{14b}@anchor{gnat_ugn/gnat_utility_programs running-gnatls}@anchor{14c} +@anchor{gnat_ugn/gnat_utility_programs id6}@anchor{13e}@anchor{gnat_ugn/gnat_utility_programs running-gnatls}@anchor{13f} @subsection Running @code{gnatls} @@ -17727,7 +17506,7 @@ $ gnatls switches object_or_ali_file @end quotation The main argument is the list of object or @code{ali} files -(see @ref{42,,The Ada Library Information Files}) +(see @ref{28,,The Ada Library Information Files}) for which information is requested. In normal mode, without additional option, @code{gnatls} produces a @@ -17793,7 +17572,7 @@ version of the same source that has been modified. @end table @node Switches for gnatls,Example of gnatls Usage,Running gnatls,The GNAT Library Browser gnatls -@anchor{gnat_ugn/gnat_utility_programs id7}@anchor{14d}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatls}@anchor{14e} +@anchor{gnat_ugn/gnat_utility_programs id7}@anchor{140}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatls}@anchor{141} @subsection Switches for @code{gnatls} @@ -17908,7 +17687,7 @@ Several such switches may be specified simultaneously. @item @code{-aO@emph{dir}}, @code{-aI@emph{dir}}, @code{-I@emph{dir}}, @code{-I-}, @code{-nostdinc} Source path manipulation. Same meaning as the equivalent @code{gnatmake} -flags (@ref{dc,,Switches for gnatmake}). +flags (@ref{cd,,Switches for gnatmake}). @end table @geindex -aP (gnatls) @@ -17929,7 +17708,7 @@ Add @code{dir} at the beginning of the project search dir. @item @code{--RTS=@emph{rts-path}} Specifies the default location of the runtime library. Same meaning as the -equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}). +equivalent @code{gnatmake} flag (@ref{cd,,Switches for gnatmake}). @end table @geindex -v (gnatls) @@ -17975,7 +17754,7 @@ by the user. @end table @node Example of gnatls Usage,,Switches for gnatls,The GNAT Library Browser gnatls -@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{14f}@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{150} +@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{142}@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{143} @subsection Example of @code{gnatls} Usage @@ -18054,1140 +17833,6 @@ instr.ads @end example @end quotation -@node The Cross-Referencing Tools gnatxref and gnatfind,The Ada to HTML Converter gnathtml,The GNAT Library Browser gnatls,GNAT Utility Programs -@anchor{gnat_ugn/gnat_utility_programs the-cross-referencing-tools-gnatxref-and-gnatfind}@anchor{22}@anchor{gnat_ugn/gnat_utility_programs id9}@anchor{151} -@section The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind} - - -@geindex gnatxref - -@geindex gnatfind - -The compiler generates cross-referencing information (unless -you set the @code{-gnatx} switch), which are saved in the @code{.ali} files. -This information indicates where in the source each entity is declared and -referenced. Note that entities in package Standard are not included, but -entities in all other predefined units are included in the output. - -Before using any of these two tools, you need to compile successfully your -application, so that GNAT gets a chance to generate the cross-referencing -information. - -The two tools @code{gnatxref} and @code{gnatfind} take advantage of this -information to provide the user with the capability to easily locate the -declaration and references to an entity. These tools are quite similar, -the difference being that @code{gnatfind} is intended for locating -definitions and/or references to a specified entity or entities, whereas -@code{gnatxref} is oriented to generating a full report of all -cross-references. - -To use these tools, you must not compile your application using the -@code{-gnatx} switch on the @code{gnatmake} command line -(see @ref{1b,,Building with gnatmake}). Otherwise, cross-referencing -information will not be generated. - -@menu -* gnatxref Switches:: -* gnatfind Switches:: -* Configuration Files for gnatxref and gnatfind:: -* Regular Expressions in gnatfind and gnatxref:: -* Examples of gnatxref Usage:: -* Examples of gnatfind Usage:: - -@end menu - -@node gnatxref Switches,gnatfind Switches,,The Cross-Referencing Tools gnatxref and gnatfind -@anchor{gnat_ugn/gnat_utility_programs id10}@anchor{152}@anchor{gnat_ugn/gnat_utility_programs gnatxref-switches}@anchor{153} -@subsection @code{gnatxref} Switches - - -The command invocation for @code{gnatxref} is: - -@quotation - -@example -$ gnatxref [ switches ] sourcefile1 [ sourcefile2 ... ] -@end example -@end quotation - -where - - -@table @asis - -@item @code{sourcefile1} [, @code{sourcefile2} ...] - -identify the source files for which a report is to be generated. The -@code{with}ed units will be processed too. You must provide at least one file. - -These file names are considered to be regular expressions, so for instance -specifying @code{source*.adb} is the same as giving every file in the current -directory whose name starts with @code{source} and whose extension is -@code{adb}. - -You shouldn't specify any directory name, just base names. @code{gnatxref} -and @code{gnatfind} will be able to locate these files by themselves using -the source path. If you specify directories, no result is produced. -@end table - -The following switches are available for @code{gnatxref}: - -@geindex --version (gnatxref) - - -@table @asis - -@item @code{--version} - -Display copyright and version, then exit disregarding all other options. -@end table - -@geindex --help (gnatxref) - - -@table @asis - -@item @code{--help} - -If @code{--version} was not used, display usage, then exit disregarding -all other options. -@end table - -@geindex -a (gnatxref) - - -@table @asis - -@item @code{-a} - -If this switch is present, @code{gnatfind} and @code{gnatxref} will parse -the read-only files found in the library search path. Otherwise, these files -will be ignored. This option can be used to protect Gnat sources or your own -libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref} -much faster, and their output much smaller. Read-only here refers to access -or permissions status in the file system for the current user. -@end table - -@geindex -aIDIR (gnatxref) - - -@table @asis - -@item @code{-aI@emph{DIR}} - -When looking for source files also look in directory DIR. The order in which -source file search is undertaken is the same as for @code{gnatmake}. -@end table - -@geindex -aODIR (gnatxref) - - -@table @asis - -@item @code{aO@emph{DIR}} - -When -searching for library and object files, look in directory -DIR. The order in which library files are searched is the same as for -@code{gnatmake}. -@end table - -@geindex -nostdinc (gnatxref) - - -@table @asis - -@item @code{-nostdinc} - -Do not look for sources in the system default directory. -@end table - -@geindex -nostdlib (gnatxref) - - -@table @asis - -@item @code{-nostdlib} - -Do not look for library files in the system default directory. -@end table - -@geindex --ext (gnatxref) - - -@table @asis - -@item @code{--ext=@emph{extension}} - -Specify an alternate ali file extension. The default is @code{ali} and other -extensions (e.g. @code{gli} for C/C++ sources) may be specified via this switch. -Note that if this switch overrides the default, only the new extension will -be considered. -@end table - -@geindex --RTS (gnatxref) - - -@table @asis - -@item @code{--RTS=@emph{rts-path}} - -Specifies the default location of the runtime library. Same meaning as the -equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}). -@end table - -@geindex -d (gnatxref) - - -@table @asis - -@item @code{-d} - -If this switch is set @code{gnatxref} will output the parent type -reference for each matching derived types. -@end table - -@geindex -f (gnatxref) - - -@table @asis - -@item @code{-f} - -If this switch is set, the output file names will be preceded by their -directory (if the file was found in the search path). If this switch is -not set, the directory will not be printed. -@end table - -@geindex -g (gnatxref) - - -@table @asis - -@item @code{-g} - -If this switch is set, information is output only for library-level -entities, ignoring local entities. The use of this switch may accelerate -@code{gnatfind} and @code{gnatxref}. -@end table - -@geindex -IDIR (gnatxref) - - -@table @asis - -@item @code{-I@emph{DIR}} - -Equivalent to @code{-aODIR -aIDIR}. -@end table - -@geindex -pFILE (gnatxref) - - -@table @asis - -@item @code{-p@emph{FILE}} - -Specify a configuration file to use to list the source and object directories. - -If a file is specified, then the content of the source directory and object -directory lines are added as if they had been specified respectively -by @code{-aI} and @code{-aO}. - -See @ref{154,,Configuration Files for gnatxref and gnatfind} for the syntax -of this configuration file. - -@item @code{-u} - -Output only unused symbols. This may be really useful if you give your -main compilation unit on the command line, as @code{gnatxref} will then -display every unused entity and 'with'ed package. - -@item @code{-v} - -Instead of producing the default output, @code{gnatxref} will generate a -@code{tags} file that can be used by vi. For examples how to use this -feature, see @ref{155,,Examples of gnatxref Usage}. The tags file is output -to the standard output, thus you will have to redirect it to a file. -@end table - -All these switches may be in any order on the command line, and may even -appear after the file names. They need not be separated by spaces, thus -you can say @code{gnatxref -ag} instead of @code{gnatxref -a -g}. - -@node gnatfind Switches,Configuration Files for gnatxref and gnatfind,gnatxref Switches,The Cross-Referencing Tools gnatxref and gnatfind -@anchor{gnat_ugn/gnat_utility_programs id11}@anchor{156}@anchor{gnat_ugn/gnat_utility_programs gnatfind-switches}@anchor{157} -@subsection @code{gnatfind} Switches - - -The command invocation for @code{gnatfind} is: - -@quotation - -@example -$ gnatfind [ switches ] pattern[:sourcefile[:line[:column]]] - [file1 file2 ...] -@end example -@end quotation - -with the following iterpretation of the command arguments: - - -@table @asis - -@item @emph{pattern} - -An entity will be output only if it matches the regular expression found -in @emph{pattern}, see @ref{158,,Regular Expressions in gnatfind and gnatxref}. - -Omitting the pattern is equivalent to specifying @code{*}, which -will match any entity. Note that if you do not provide a pattern, you -have to provide both a sourcefile and a line. - -Entity names are given in Latin-1, with uppercase/lowercase equivalence -for matching purposes. At the current time there is no support for -8-bit codes other than Latin-1, or for wide characters in identifiers. - -@item @emph{sourcefile} - -@code{gnatfind} will look for references, bodies or declarations -of symbols referenced in @code{sourcefile}, at line @code{line} -and column @code{column}. See @ref{159,,Examples of gnatfind Usage} -for syntax examples. - -@item @emph{line} - -A decimal integer identifying the line number containing -the reference to the entity (or entities) to be located. - -@item @emph{column} - -A decimal integer identifying the exact location on the -line of the first character of the identifier for the -entity reference. Columns are numbered from 1. - -@item @emph{file1 file2 ...} - -The search will be restricted to these source files. If none are given, then -the search will be conducted for every library file in the search path. -These files must appear only after the pattern or sourcefile. - -These file names are considered to be regular expressions, so for instance -specifying @code{source*.adb} is the same as giving every file in the current -directory whose name starts with @code{source} and whose extension is -@code{adb}. - -The location of the spec of the entity will always be displayed, even if it -isn't in one of @code{file1}, @code{file2}, ... The -occurrences of the entity in the separate units of the ones given on the -command line will also be displayed. - -Note that if you specify at least one file in this part, @code{gnatfind} may -sometimes not be able to find the body of the subprograms. -@end table - -At least one of 'sourcefile' or 'pattern' has to be present on -the command line. - -The following switches are available: - -@geindex --version (gnatfind) - - -@table @asis - -@item @code{--version} - -Display copyright and version, then exit disregarding all other options. -@end table - -@geindex --help (gnatfind) - - -@table @asis - -@item @code{--help} - -If @code{--version} was not used, display usage, then exit disregarding -all other options. -@end table - -@geindex -a (gnatfind) - - -@table @asis - -@item @code{-a} - -If this switch is present, @code{gnatfind} and @code{gnatxref} will parse -the read-only files found in the library search path. Otherwise, these files -will be ignored. This option can be used to protect Gnat sources or your own -libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref} -much faster, and their output much smaller. Read-only here refers to access -or permission status in the file system for the current user. -@end table - -@geindex -aIDIR (gnatfind) - - -@table @asis - -@item @code{-aI@emph{DIR}} - -When looking for source files also look in directory DIR. The order in which -source file search is undertaken is the same as for @code{gnatmake}. -@end table - -@geindex -aODIR (gnatfind) - - -@table @asis - -@item @code{-aO@emph{DIR}} - -When searching for library and object files, look in directory -DIR. The order in which library files are searched is the same as for -@code{gnatmake}. -@end table - -@geindex -nostdinc (gnatfind) - - -@table @asis - -@item @code{-nostdinc} - -Do not look for sources in the system default directory. -@end table - -@geindex -nostdlib (gnatfind) - - -@table @asis - -@item @code{-nostdlib} - -Do not look for library files in the system default directory. -@end table - -@geindex --ext (gnatfind) - - -@table @asis - -@item @code{--ext=@emph{extension}} - -Specify an alternate ali file extension. The default is @code{ali} and other -extensions may be specified via this switch. Note that if this switch -overrides the default, only the new extension will be considered. -@end table - -@geindex --RTS (gnatfind) - - -@table @asis - -@item @code{--RTS=@emph{rts-path}} - -Specifies the default location of the runtime library. Same meaning as the -equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}). -@end table - -@geindex -d (gnatfind) - - -@table @asis - -@item @code{-d} - -If this switch is set, then @code{gnatfind} will output the parent type -reference for each matching derived types. -@end table - -@geindex -e (gnatfind) - - -@table @asis - -@item @code{-e} - -By default, @code{gnatfind} accept the simple regular expression set for -@code{pattern}. If this switch is set, then the pattern will be -considered as full Unix-style regular expression. -@end table - -@geindex -f (gnatfind) - - -@table @asis - -@item @code{-f} - -If this switch is set, the output file names will be preceded by their -directory (if the file was found in the search path). If this switch is -not set, the directory will not be printed. -@end table - -@geindex -g (gnatfind) - - -@table @asis - -@item @code{-g} - -If this switch is set, information is output only for library-level -entities, ignoring local entities. The use of this switch may accelerate -@code{gnatfind} and @code{gnatxref}. -@end table - -@geindex -IDIR (gnatfind) - - -@table @asis - -@item @code{-I@emph{DIR}} - -Equivalent to @code{-aODIR -aIDIR}. -@end table - -@geindex -pFILE (gnatfind) - - -@table @asis - -@item @code{-p@emph{FILE}} - -Specify a configuration file to use to list the source and object directories. - -If a file is specified, then the content of the source directory and object -directory lines are added as if they had been specified respectively -by @code{-aI} and @code{-aO}. - -See @ref{154,,Configuration Files for gnatxref and gnatfind} for the syntax -of this configuration file. -@end table - -@geindex -r (gnatfind) - - -@table @asis - -@item @code{-r} - -By default, @code{gnatfind} will output only the information about the -declaration, body or type completion of the entities. If this switch is -set, the @code{gnatfind} will locate every reference to the entities in -the files specified on the command line (or in every file in the search -path if no file is given on the command line). -@end table - -@geindex -s (gnatfind) - - -@table @asis - -@item @code{-s} - -If this switch is set, then @code{gnatfind} will output the content -of the Ada source file lines were the entity was found. -@end table - -@geindex -t (gnatfind) - - -@table @asis - -@item @code{-t} - -If this switch is set, then @code{gnatfind} will output the type hierarchy for -the specified type. It act like -d option but recursively from parent -type to parent type. When this switch is set it is not possible to -specify more than one file. -@end table - -All these switches may be in any order on the command line, and may even -appear after the file names. They need not be separated by spaces, thus -you can say @code{gnatxref -ag} instead of -@code{gnatxref -a -g}. - -As stated previously, @code{gnatfind} will search in every directory in the -search path. You can force it to look only in the current directory if -you specify @code{*} at the end of the command line. - -@node Configuration Files for gnatxref and gnatfind,Regular Expressions in gnatfind and gnatxref,gnatfind Switches,The Cross-Referencing Tools gnatxref and gnatfind -@anchor{gnat_ugn/gnat_utility_programs configuration-files-for-gnatxref-and-gnatfind}@anchor{154}@anchor{gnat_ugn/gnat_utility_programs id12}@anchor{15a} -@subsection Configuration Files for @code{gnatxref} and @code{gnatfind} - - -Configuration files are used by @code{gnatxref} and @code{gnatfind} to specify -the list of source and object directories to consider. They can be -specified via the @code{-p} switch. - -The following lines can be included, in any order in the file: - - -@itemize * - -@item - -@table @asis - -@item @emph{src_dir=DIR} - -[default: @code{"./"}]. -Specifies a directory where to look for source files. Multiple @code{src_dir} -lines can be specified and they will be searched in the order they -are specified. -@end table - -@item - -@table @asis - -@item @emph{obj_dir=DIR} - -[default: @code{"./"}]. -Specifies a directory where to look for object and library files. Multiple -@code{obj_dir} lines can be specified, and they will be searched in the order -they are specified -@end table -@end itemize - -Any other line will be silently ignored. - -@node Regular Expressions in gnatfind and gnatxref,Examples of gnatxref Usage,Configuration Files for gnatxref and gnatfind,The Cross-Referencing Tools gnatxref and gnatfind -@anchor{gnat_ugn/gnat_utility_programs id13}@anchor{15b}@anchor{gnat_ugn/gnat_utility_programs regular-expressions-in-gnatfind-and-gnatxref}@anchor{158} -@subsection Regular Expressions in @code{gnatfind} and @code{gnatxref} - - -As specified in the section about @code{gnatfind}, the pattern can be a -regular expression. Two kinds of regular expressions -are recognized: - - -@itemize * - -@item - -@table @asis - -@item @emph{Globbing pattern} - -These are the most common regular expression. They are the same as are -generally used in a Unix shell command line, or in a DOS session. - -Here is a more formal grammar: - -@example -regexp ::= term -term ::= elmt -- matches elmt -term ::= elmt elmt -- concatenation (elmt then elmt) -term ::= * -- any string of 0 or more characters -term ::= ? -- matches any character -term ::= [char @{char@}] -- matches any character listed -term ::= [char - char] -- matches any character in range -@end example -@end table - -@item - -@table @asis - -@item @emph{Full regular expression} - -The second set of regular expressions is much more powerful. This is the -type of regular expressions recognized by utilities such as @code{grep}. - -The following is the form of a regular expression, expressed in same BNF -style as is found in the Ada Reference Manual: - -@example -regexp ::= term @{| term@} -- alternation (term or term ...) - -term ::= item @{item@} -- concatenation (item then item) - -item ::= elmt -- match elmt -item ::= elmt * -- zero or more elmt's -item ::= elmt + -- one or more elmt's -item ::= elmt ? -- matches elmt or nothing - -elmt ::= nschar -- matches given character -elmt ::= [nschar @{nschar@}] -- matches any character listed -elmt ::= [^ nschar @{nschar@}] -- matches any character not listed -elmt ::= [char - char] -- matches chars in given range -elmt ::= \\ char -- matches given character -elmt ::= . -- matches any single character -elmt ::= ( regexp ) -- parens used for grouping - -char ::= any character, including special characters -nschar ::= any character except ()[].*+?^ -@end example - -Here are a few examples: - -@quotation - - -@table @asis - -@item @code{abcde|fghi} - -will match any of the two strings @code{abcde} and @code{fghi}, - -@item @code{abc*d} - -will match any string like @code{abd}, @code{abcd}, @code{abccd}, -@code{abcccd}, and so on, - -@item @code{[a-z]+} - -will match any string which has only lowercase characters in it (and at -least one character. -@end table -@end quotation -@end table -@end itemize - -@node Examples of gnatxref Usage,Examples of gnatfind Usage,Regular Expressions in gnatfind and gnatxref,The Cross-Referencing Tools gnatxref and gnatfind -@anchor{gnat_ugn/gnat_utility_programs examples-of-gnatxref-usage}@anchor{155}@anchor{gnat_ugn/gnat_utility_programs id14}@anchor{15c} -@subsection Examples of @code{gnatxref} Usage - - -@menu -* General Usage:: -* Using gnatxref with vi:: - -@end menu - -@node General Usage,Using gnatxref with vi,,Examples of gnatxref Usage -@anchor{gnat_ugn/gnat_utility_programs general-usage}@anchor{15d} -@subsubsection General Usage - - -For the following examples, we will consider the following units: - -@quotation - -@example -main.ads: -1: with Bar; -2: package Main is -3: procedure Foo (B : in Integer); -4: C : Integer; -5: private -6: D : Integer; -7: end Main; - -main.adb: -1: package body Main is -2: procedure Foo (B : in Integer) is -3: begin -4: C := B; -5: D := B; -6: Bar.Print (B); -7: Bar.Print (C); -8: end Foo; -9: end Main; - -bar.ads: -1: package Bar is -2: procedure Print (B : Integer); -3: end bar; -@end example -@end quotation - -The first thing to do is to recompile your application (for instance, in -that case just by doing a @code{gnatmake main}, so that GNAT generates -the cross-referencing information. -You can then issue any of the following commands: - -@quotation - - -@itemize * - -@item -@code{gnatxref main.adb} -@code{gnatxref} generates cross-reference information for main.adb -and every unit 'with'ed by main.adb. - -The output would be: - -@quotation - -@example -B Type: Integer - Decl: bar.ads 2:22 -B Type: Integer - Decl: main.ads 3:20 - Body: main.adb 2:20 - Ref: main.adb 4:13 5:13 6:19 -Bar Type: Unit - Decl: bar.ads 1:9 - Ref: main.adb 6:8 7:8 - main.ads 1:6 -C Type: Integer - Decl: main.ads 4:5 - Modi: main.adb 4:8 - Ref: main.adb 7:19 -D Type: Integer - Decl: main.ads 6:5 - Modi: main.adb 5:8 -Foo Type: Unit - Decl: main.ads 3:15 - Body: main.adb 2:15 -Main Type: Unit - Decl: main.ads 2:9 - Body: main.adb 1:14 -Print Type: Unit - Decl: bar.ads 2:15 - Ref: main.adb 6:12 7:12 -@end example -@end quotation - -This shows that the entity @code{Main} is declared in main.ads, line 2, column 9, -its body is in main.adb, line 1, column 14 and is not referenced any where. - -The entity @code{Print} is declared in @code{bar.ads}, line 2, column 15 and it -is referenced in @code{main.adb}, line 6 column 12 and line 7 column 12. - -@item -@code{gnatxref package1.adb package2.ads} -@code{gnatxref} will generates cross-reference information for -@code{package1.adb}, @code{package2.ads} and any other package @code{with}ed by any -of these. -@end itemize -@end quotation - -@node Using gnatxref with vi,,General Usage,Examples of gnatxref Usage -@anchor{gnat_ugn/gnat_utility_programs using-gnatxref-with-vi}@anchor{15e} -@subsubsection Using @code{gnatxref} with @code{vi} - - -@code{gnatxref} can generate a tags file output, which can be used -directly from @code{vi}. Note that the standard version of @code{vi} -will not work properly with overloaded symbols. Consider using another -free implementation of @code{vi}, such as @code{vim}. - -@quotation - -@example -$ gnatxref -v gnatfind.adb > tags -@end example -@end quotation - -The following command will generate the tags file for @code{gnatfind} itself -(if the sources are in the search path!): - -@quotation - -@example -$ gnatxref -v gnatfind.adb > tags -@end example -@end quotation - -From @code{vi}, you can then use the command @code{:tag @emph{entity}} -(replacing @code{entity} by whatever you are looking for), and vi will -display a new file with the corresponding declaration of entity. - -@node Examples of gnatfind Usage,,Examples of gnatxref Usage,The Cross-Referencing Tools gnatxref and gnatfind -@anchor{gnat_ugn/gnat_utility_programs id15}@anchor{15f}@anchor{gnat_ugn/gnat_utility_programs examples-of-gnatfind-usage}@anchor{159} -@subsection Examples of @code{gnatfind} Usage - - - -@itemize * - -@item -@code{gnatfind -f xyz:main.adb} -Find declarations for all entities xyz referenced at least once in -main.adb. The references are search in every library file in the search -path. - -The directories will be printed as well (as the @code{-f} -switch is set) - -The output will look like: - -@quotation - -@example -directory/main.ads:106:14: xyz <= declaration -directory/main.adb:24:10: xyz <= body -directory/foo.ads:45:23: xyz <= declaration -@end example -@end quotation - -I.e., one of the entities xyz found in main.adb is declared at -line 12 of main.ads (and its body is in main.adb), and another one is -declared at line 45 of foo.ads - -@item -@code{gnatfind -fs xyz:main.adb} -This is the same command as the previous one, but @code{gnatfind} will -display the content of the Ada source file lines. - -The output will look like: - -@example -directory/main.ads:106:14: xyz <= declaration - procedure xyz; -directory/main.adb:24:10: xyz <= body - procedure xyz is -directory/foo.ads:45:23: xyz <= declaration - xyz : Integer; -@end example - -This can make it easier to find exactly the location your are looking -for. - -@item -@code{gnatfind -r "*x*":main.ads:123 foo.adb} -Find references to all entities containing an x that are -referenced on line 123 of main.ads. -The references will be searched only in main.ads and foo.adb. - -@item -@code{gnatfind main.ads:123} -Find declarations and bodies for all entities that are referenced on -line 123 of main.ads. - -This is the same as @code{gnatfind "*":main.adb:123`} - -@item -@code{gnatfind mydir/main.adb:123:45} -Find the declaration for the entity referenced at column 45 in -line 123 of file main.adb in directory mydir. Note that it -is usual to omit the identifier name when the column is given, -since the column position identifies a unique reference. - -The column has to be the beginning of the identifier, and should not -point to any character in the middle of the identifier. -@end itemize - -@node The Ada to HTML Converter gnathtml,,The Cross-Referencing Tools gnatxref and gnatfind,GNAT Utility Programs -@anchor{gnat_ugn/gnat_utility_programs the-ada-to-html-converter-gnathtml}@anchor{23}@anchor{gnat_ugn/gnat_utility_programs id16}@anchor{160} -@section The Ada to HTML Converter @code{gnathtml} - - -@geindex gnathtml - -@code{gnathtml} is a Perl script that allows Ada source files to be browsed using -standard Web browsers. For installation information, see @ref{161,,Installing gnathtml}. - -Ada reserved keywords are highlighted in a bold font and Ada comments in -a blue font. Unless your program was compiled with the gcc @code{-gnatx} -switch to suppress the generation of cross-referencing information, user -defined variables and types will appear in a different color; you will -be able to click on any identifier and go to its declaration. - -@menu -* Invoking gnathtml:: -* Installing gnathtml:: - -@end menu - -@node Invoking gnathtml,Installing gnathtml,,The Ada to HTML Converter gnathtml -@anchor{gnat_ugn/gnat_utility_programs invoking-gnathtml}@anchor{162}@anchor{gnat_ugn/gnat_utility_programs id17}@anchor{163} -@subsection Invoking @code{gnathtml} - - -The command line is as follows: - -@quotation - -@example -$ perl gnathtml.pl [ switches ] ada-files -@end example -@end quotation - -You can specify as many Ada files as you want. @code{gnathtml} will generate -an html file for every ada file, and a global file called @code{index.htm}. -This file is an index of every identifier defined in the files. - -The following switches are available: - -@geindex -83 (gnathtml) - - -@table @asis - -@item @code{83} - -Only the Ada 83 subset of keywords will be highlighted. -@end table - -@geindex -cc (gnathtml) - - -@table @asis - -@item @code{cc @emph{color}} - -This option allows you to change the color used for comments. The default -value is green. The color argument can be any name accepted by html. -@end table - -@geindex -d (gnathtml) - - -@table @asis - -@item @code{d} - -If the Ada files depend on some other files (for instance through -@code{with} clauses, the latter files will also be converted to html. -Only the files in the user project will be converted to html, not the files -in the run-time library itself. -@end table - -@geindex -D (gnathtml) - - -@table @asis - -@item @code{D} - -This command is the same as @code{-d} above, but @code{gnathtml} will -also look for files in the run-time library, and generate html files for them. -@end table - -@geindex -ext (gnathtml) - - -@table @asis - -@item @code{ext @emph{extension}} - -This option allows you to change the extension of the generated HTML files. -If you do not specify an extension, it will default to @code{htm}. -@end table - -@geindex -f (gnathtml) - - -@table @asis - -@item @code{f} - -By default, gnathtml will generate html links only for global entities -('with'ed units, global variables and types,...). If you specify -@code{-f} on the command line, then links will be generated for local -entities too. -@end table - -@geindex -l (gnathtml) - - -@table @asis - -@item @code{l @emph{number}} - -If this switch is provided and @code{number} is not 0, then -@code{gnathtml} will number the html files every @code{number} line. -@end table - -@geindex -I (gnathtml) - - -@table @asis - -@item @code{I @emph{dir}} - -Specify a directory to search for library files (@code{.ALI} files) and -source files. You can provide several -I switches on the command line, -and the directories will be parsed in the order of the command line. -@end table - -@geindex -o (gnathtml) - - -@table @asis - -@item @code{o @emph{dir}} - -Specify the output directory for html files. By default, gnathtml will -saved the generated html files in a subdirectory named @code{html/}. -@end table - -@geindex -p (gnathtml) - - -@table @asis - -@item @code{p @emph{file}} - -If you are using Emacs and the most recent Emacs Ada mode, which provides -a full Integrated Development Environment for compiling, checking, -running and debugging applications, you may use @code{.gpr} files -to give the directories where Emacs can find sources and object files. - -Using this switch, you can tell gnathtml to use these files. -This allows you to get an html version of your application, even if it -is spread over multiple directories. -@end table - -@geindex -sc (gnathtml) - - -@table @asis - -@item @code{sc @emph{color}} - -This switch allows you to change the color used for symbol -definitions. -The default value is red. The color argument can be any name accepted by html. -@end table - -@geindex -t (gnathtml) - - -@table @asis - -@item @code{t @emph{file}} - -This switch provides the name of a file. This file contains a list of -file names to be converted, and the effect is exactly as though they had -appeared explicitly on the command line. This -is the recommended way to work around the command line length limit on some -systems. -@end table - -@node Installing gnathtml,,Invoking gnathtml,The Ada to HTML Converter gnathtml -@anchor{gnat_ugn/gnat_utility_programs installing-gnathtml}@anchor{161}@anchor{gnat_ugn/gnat_utility_programs id18}@anchor{164} -@subsection Installing @code{gnathtml} - - -@code{Perl} needs to be installed on your machine to run this script. -@code{Perl} is freely available for almost every architecture and -operating system via the Internet. - -On Unix systems, you may want to modify the first line of the script -@code{gnathtml}, to explicitly specify where Perl -is located. The syntax of this line is: - -@quotation - -@example -#!full_path_name_to_perl -@end example -@end quotation - -Alternatively, you may run the script using the following command line: - -@quotation - -@example -$ perl gnathtml.pl [ switches ] files -@end example -@end quotation - -@c -- +---------------------------------------------------------------------+ - -@c -- | The following sections are present only in the PRO and GPL editions | - -@c -- +---------------------------------------------------------------------+ - - @@ -19198,7 +17843,7 @@ $ perl gnathtml.pl [ switches ] files @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node GNAT and Program Execution,Platform-Specific Information,GNAT Utility Programs,Top -@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{c}@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{165}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{166} +@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{c}@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{144}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{145} @chapter GNAT and Program Execution @@ -19208,25 +17853,25 @@ This chapter covers several topics: @itemize * @item -@ref{167,,Running and Debugging Ada Programs} +@ref{146,,Running and Debugging Ada Programs} @item -@ref{25,,Profiling} +@ref{147,,Profiling} @item -@ref{168,,Improving Performance} +@ref{148,,Improving Performance} @item -@ref{169,,Overflow Check Handling in GNAT} +@ref{149,,Overflow Check Handling in GNAT} @item -@ref{16a,,Performing Dimensionality Analysis in GNAT} +@ref{14a,,Performing Dimensionality Analysis in GNAT} @item -@ref{16b,,Stack Related Facilities} +@ref{14b,,Stack Related Facilities} @item -@ref{16c,,Memory Management Issues} +@ref{14c,,Memory Management Issues} @end itemize @menu @@ -19241,7 +17886,7 @@ This chapter covers several topics: @end menu @node Running and Debugging Ada Programs,Profiling,,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{167}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{24} +@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{146}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{14d} @section Running and Debugging Ada Programs @@ -19295,7 +17940,7 @@ the incorrect user program. @end menu @node The GNAT Debugger GDB,Running GDB,,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{16d}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{16e} +@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{14e}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{14f} @subsection The GNAT Debugger GDB @@ -19352,7 +17997,7 @@ the debugging information and can respond to user commands to inspect variables, and more generally to report on the state of execution. @node Running GDB,Introduction to GDB Commands,The GNAT Debugger GDB,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{16f}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{170} +@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{150}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{151} @subsection Running GDB @@ -19379,7 +18024,7 @@ exactly as if the debugger were not present. The following section describes some of the additional commands that can be given to @code{GDB}. @node Introduction to GDB Commands,Using Ada Expressions,Running GDB,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{171}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{172} +@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{152}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{153} @subsection Introduction to GDB Commands @@ -19587,7 +18232,7 @@ Note that most commands can be abbreviated (for example, c for continue, bt for backtrace). @node Using Ada Expressions,Calling User-Defined Subprograms,Introduction to GDB Commands,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{174} +@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{154}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{155} @subsection Using Ada Expressions @@ -19625,7 +18270,7 @@ their packages, regardless of context. Where this causes ambiguity, For details on the supported Ada syntax, see @cite{Debugging with GDB}. @node Calling User-Defined Subprograms,Using the next Command in a Function,Using Ada Expressions,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{176} +@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{156}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{157} @subsection Calling User-Defined Subprograms @@ -19684,7 +18329,7 @@ elements directly from GDB, you can write a callable procedure that prints the elements in the desired format. @node Using the next Command in a Function,Stopping When Ada Exceptions Are Raised,Calling User-Defined Subprograms,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{178} +@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{158}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{159} @subsection Using the @emph{next} Command in a Function @@ -19707,7 +18352,7 @@ The value returned is always that from the first return statement that was stepped through. @node Stopping When Ada Exceptions Are Raised,Ada Tasks,Using the next Command in a Function,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{179}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{17a} +@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{15a}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{15b} @subsection Stopping When Ada Exceptions Are Raised @@ -19764,7 +18409,7 @@ argument, prints out only those exceptions whose name matches @emph{regexp}. @geindex Tasks (in gdb) @node Ada Tasks,Debugging Generic Units,Stopping When Ada Exceptions Are Raised,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{17b}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{17c} +@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{15c}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{15d} @subsection Ada Tasks @@ -19851,7 +18496,7 @@ see @cite{Debugging with GDB}. @geindex Generics @node Debugging Generic Units,Remote Debugging with gdbserver,Ada Tasks,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{17d}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{17e} +@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{15e}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{15f} @subsection Debugging Generic Units @@ -19910,7 +18555,7 @@ other units. @geindex Remote Debugging with gdbserver @node Remote Debugging with gdbserver,GNAT Abnormal Termination or Failure to Terminate,Debugging Generic Units,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{17f}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{180} +@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{160}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{161} @subsection Remote Debugging with gdbserver @@ -19968,7 +18613,7 @@ GNAT provides support for gdbserver on x86-linux, x86-windows and x86_64-linux. @geindex Abnormal Termination or Failure to Terminate @node GNAT Abnormal Termination or Failure to Terminate,Naming Conventions for GNAT Source Files,Remote Debugging with gdbserver,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{181}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{182} +@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{162}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{163} @subsection GNAT Abnormal Termination or Failure to Terminate @@ -20023,7 +18668,7 @@ Finally, you can start @code{gdb} directly on the @code{gnat1} executable. @code{gnat1} is the front-end of GNAT, and can be run independently (normally it is just called from @code{gcc}). You can use @code{gdb} on @code{gnat1} as you -would on a C program (but @ref{16d,,The GNAT Debugger GDB} for caveats). The +would on a C program (but @ref{14e,,The GNAT Debugger GDB} for caveats). The @code{where} command is the first line of attack; the variable @code{lineno} (seen by @code{print lineno}), used by the second phase of @code{gnat1} and by the @code{gcc} backend, indicates the source line at @@ -20032,7 +18677,7 @@ the source file. @end itemize @node Naming Conventions for GNAT Source Files,Getting Internal Debugging Information,GNAT Abnormal Termination or Failure to Terminate,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{183}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{184} +@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{164}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{165} @subsection Naming Conventions for GNAT Source Files @@ -20113,7 +18758,7 @@ the other @code{.c} files are modifications of common @code{gcc} files. @end itemize @node Getting Internal Debugging Information,Stack Traceback,Naming Conventions for GNAT Source Files,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{186} +@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{166}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{167} @subsection Getting Internal Debugging Information @@ -20141,7 +18786,7 @@ are replaced with run-time calls. @geindex stack unwinding @node Stack Traceback,Pretty-Printers for the GNAT runtime,Getting Internal Debugging Information,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{187}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{188} +@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{168}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{169} @subsection Stack Traceback @@ -20170,7 +18815,7 @@ is enabled, and no exception is raised during program execution. @end menu @node Non-Symbolic Traceback,Symbolic Traceback,,Stack Traceback -@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{189}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{18a} +@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{16b} @subsubsection Non-Symbolic Traceback @@ -20297,7 +18942,7 @@ From this traceback we can see that the exception was raised in @code{stb.adb} at line 5, which was reached from a procedure call in @code{stb.adb} at line 10, and so on. The @code{b~std.adb} is the binder file, which contains the call to the main program. -@ref{11c,,Running gnatbind}. The remaining entries are assorted runtime routines, +@ref{10d,,Running gnatbind}. The remaining entries are assorted runtime routines, and the output will vary from platform to platform. It is also possible to use @code{GDB} with these traceback addresses to debug @@ -20455,7 +19100,7 @@ need to be specified in C format, with a leading '0x'). @geindex symbolic @node Symbolic Traceback,,Non-Symbolic Traceback,Stack Traceback -@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{18b}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{18c} +@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{16d} @subsubsection Symbolic Traceback @@ -20583,7 +19228,7 @@ which will also be printed if an unhandled exception terminates the program. @node Pretty-Printers for the GNAT runtime,,Stack Traceback,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{18d}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{18e} +@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{16e}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{16f} @subsection Pretty-Printers for the GNAT runtime @@ -20690,7 +19335,7 @@ for more information. @geindex Profiling @node Profiling,Improving Performance,Running and Debugging Ada Programs,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{25}@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{18f} +@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{147}@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{170} @section Profiling @@ -20706,7 +19351,7 @@ This section describes how to use the @code{gprof} profiler tool on Ada programs @end menu @node Profiling an Ada Program with gprof,,,Profiling -@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{190}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{191} +@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{171}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{172} @subsection Profiling an Ada Program with gprof @@ -20760,7 +19405,7 @@ to interpret the results. @end menu @node Compilation for profiling,Program execution,,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{192}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{193} +@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{174} @subsubsection Compilation for profiling @@ -20788,7 +19433,7 @@ be profiled; if you need to profile your whole project, use the @code{-f} gnatmake switch to force full recompilation. @node Program execution,Running gprof,Compilation for profiling,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{194}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{195} +@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{176} @subsubsection Program execution @@ -20803,7 +19448,7 @@ generated in the directory where the program was launched from. If this file already exists, it will be overwritten. @node Running gprof,Interpretation of profiling results,Program execution,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{196}@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{197} +@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{178} @subsubsection Running gprof @@ -20916,7 +19561,7 @@ may be given; only one @code{function_name} may be indicated with each @end table @node Interpretation of profiling results,,Running gprof,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{198}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{199} +@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{179}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{17a} @subsubsection Interpretation of profiling results @@ -20933,7 +19578,7 @@ and the subprograms that it calls. It also provides an estimate of the time spent in each of those callers/called subprograms. @node Improving Performance,Overflow Check Handling in GNAT,Profiling,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{26}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{168} +@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{17b}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{148} @section Improving Performance @@ -20954,7 +19599,7 @@ which can reduce the size of program executables. @end menu @node Performance Considerations,Text_IO Suggestions,,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{19a}@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{19b} +@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{17c}@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{17d} @subsection Performance Considerations @@ -21015,7 +19660,7 @@ some guidelines on debugging optimized code. @end menu @node Controlling Run-Time Checks,Use of Restrictions,,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{19c}@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{19d} +@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{17e}@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{17f} @subsubsection Controlling Run-Time Checks @@ -21029,7 +19674,7 @@ necessary checking is done at compile time. @geindex -gnato (gcc) The gnat switch, @code{-gnatp} allows this default to be modified. See -@ref{f9,,Run-Time Checks}. +@ref{ea,,Run-Time Checks}. Our experience is that the default is suitable for most development purposes. @@ -21067,7 +19712,7 @@ remove checks) or @code{pragma Unsuppress} (to add back suppressed checks) in the program source. @node Use of Restrictions,Optimization Levels,Controlling Run-Time Checks,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{19f} +@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{180}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{181} @subsubsection Use of Restrictions @@ -21102,7 +19747,7 @@ that this also means that you can write code without worrying about the possibility of an immediate abort at any point. @node Optimization Levels,Debugging Optimized Code,Use of Restrictions,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{fc} +@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{182}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{ed} @subsubsection Optimization Levels @@ -21183,7 +19828,7 @@ the slowest compilation time. Full optimization as in @code{-O2}; also uses more aggressive automatic inlining of subprograms within a unit -(@ref{10f,,Inlining of Subprograms}) and attempts to vectorize loops. +(@ref{100,,Inlining of Subprograms}) and attempts to vectorize loops. @end table @item @@ -21223,10 +19868,10 @@ levels. Note regarding the use of @code{-O3}: The use of this optimization level ought not to be automatically preferred over that of level @code{-O2}, since it often results in larger executables which may run more slowly. -See further discussion of this point in @ref{10f,,Inlining of Subprograms}. +See further discussion of this point in @ref{100,,Inlining of Subprograms}. @node Debugging Optimized Code,Inlining of Subprograms,Optimization Levels,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{1a1}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{1a2} +@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{183}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{184} @subsubsection Debugging Optimized Code @@ -21354,7 +19999,7 @@ on the resulting executable, which removes both debugging information and global symbols. @node Inlining of Subprograms,Floating_Point_Operations,Debugging Optimized Code,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{1a3}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{10f} +@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{100} @subsubsection Inlining of Subprograms @@ -21493,7 +20138,7 @@ indeed you should use @code{-O3} only if tests show that it actually improves performance for your program. @node Floating_Point_Operations,Vectorization of loops,Inlining of Subprograms,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{1a4}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{1a5} +@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{186}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{187} @subsubsection Floating_Point_Operations @@ -21541,7 +20186,7 @@ so it is permissible to mix units compiled with and without these switches. @node Vectorization of loops,Other Optimization Switches,Floating_Point_Operations,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{1a6}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{1a7} +@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{189} @subsubsection Vectorization of loops @@ -21692,7 +20337,7 @@ placed immediately within the loop will tell the compiler that it can safely omit the non-vectorized version of the loop as well as the run-time test. @node Other Optimization Switches,Optimization and Strict Aliasing,Vectorization of loops,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{1a8}@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{1a9} +@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{18a}@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{18b} @subsubsection Other Optimization Switches @@ -21709,7 +20354,7 @@ the @emph{Submodel Options} section in the @emph{Hardware Models and Configurati chapter of @cite{Using the GNU Compiler Collection (GCC)}. @node Optimization and Strict Aliasing,Aliased Variables and Optimization,Other Optimization Switches,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{f3}@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{1aa} +@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{e4}@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{18c} @subsubsection Optimization and Strict Aliasing @@ -21949,7 +20594,7 @@ review any uses of unchecked conversion of access types, particularly if you are getting the warnings described above. @node Aliased Variables and Optimization,Atomic Variables and Optimization,Optimization and Strict Aliasing,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{1ab}@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{1ac} +@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{18d}@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{18e} @subsubsection Aliased Variables and Optimization @@ -22007,7 +20652,7 @@ This means that the above example will in fact "work" reliably, that is, it will produce the expected results. @node Atomic Variables and Optimization,Passive Task Optimization,Aliased Variables and Optimization,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{1ad}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{1ae} +@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{18f}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{190} @subsubsection Atomic Variables and Optimization @@ -22088,7 +20733,7 @@ such synchronization code is not required, it may be useful to disable it. @node Passive Task Optimization,,Atomic Variables and Optimization,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{1b0} +@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{191}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{192} @subsubsection Passive Task Optimization @@ -22133,7 +20778,7 @@ that typically clients of the tasks who call entries, will not have to be modified, only the task definition itself. @node Text_IO Suggestions,Reducing Size of Executables with Unused Subprogram/Data Elimination,Performance Considerations,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{1b1}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{1b2} +@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{193}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{194} @subsection @code{Text_IO} Suggestions @@ -22156,7 +20801,7 @@ of the standard output file, or change the standard output file to be buffered using @code{Interfaces.C_Streams.setvbuf}. @node Reducing Size of Executables with Unused Subprogram/Data Elimination,,Text_IO Suggestions,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{1b3}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{1b4} +@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{195}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{196} @subsection Reducing Size of Executables with Unused Subprogram/Data Elimination @@ -22173,7 +20818,7 @@ your executable just by setting options at compilation time. @end menu @node About unused subprogram/data elimination,Compilation options,,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{1b5}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{1b6} +@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{197}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{198} @subsubsection About unused subprogram/data elimination @@ -22189,7 +20834,7 @@ architecture and on all cross platforms using the ELF binary file format. In both cases GNU binutils version 2.16 or later are required to enable it. @node Compilation options,Example of unused subprogram/data elimination,About unused subprogram/data elimination,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{1b7}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{1b8} +@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{199}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{19a} @subsubsection Compilation options @@ -22228,7 +20873,7 @@ The GNAT static library is now compiled with -ffunction-sections and and data of the GNAT library from your executable. @node Example of unused subprogram/data elimination,,Compilation options,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{1b9}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{1ba} +@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{19b}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{19c} @subsubsection Example of unused subprogram/data elimination @@ -22298,7 +20943,7 @@ appropriate options. @geindex Checks (overflow) @node Overflow Check Handling in GNAT,Performing Dimensionality Analysis in GNAT,Improving Performance,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{169}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{27} +@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{149}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{19d} @section Overflow Check Handling in GNAT @@ -22314,7 +20959,7 @@ This section explains how to control the handling of overflow checks. @end menu @node Background,Management of Overflows in GNAT,,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{1bb}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{1bc} +@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{19f} @subsection Background @@ -22440,7 +21085,7 @@ exception raised because of the intermediate overflow (and we really would prefer this precondition to be considered True at run time). @node Management of Overflows in GNAT,Specifying the Desired Mode,Background,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1bd}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1be} +@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1a1} @subsection Management of Overflows in GNAT @@ -22554,7 +21199,7 @@ out in the normal manner (with infinite values always failing all range checks). @node Specifying the Desired Mode,Default Settings,Management of Overflows in GNAT,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{f8}@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1bf} +@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{e9}@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1a2} @subsection Specifying the Desired Mode @@ -22678,7 +21323,7 @@ causing all intermediate operations to be computed using the base type (@code{STRICT} mode). @node Default Settings,Implementation Notes,Specifying the Desired Mode,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1c0}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1c1} +@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1a3}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1a4} @subsection Default Settings @@ -22725,7 +21370,7 @@ checking, but it has no effect on the method used for computing intermediate results. @node Implementation Notes,,Default Settings,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1c2}@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1c3} +@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1a5}@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1a6} @subsection Implementation Notes @@ -22773,7 +21418,7 @@ platforms for which @code{Long_Long_Integer} is 64-bits (nearly all GNAT platforms). @node Performing Dimensionality Analysis in GNAT,Stack Related Facilities,Overflow Check Handling in GNAT,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{28}@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{16a} +@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{1a7}@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{14a} @section Performing Dimensionality Analysis in GNAT @@ -23160,7 +21805,7 @@ passing (the dimension vector for the actual parameter must be equal to the dimension vector for the formal parameter). @node Stack Related Facilities,Memory Management Issues,Performing Dimensionality Analysis in GNAT,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{29}@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{16b} +@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{1a8}@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{14b} @section Stack Related Facilities @@ -23176,7 +21821,7 @@ particular, it deals with dynamic and static stack usage measurements. @end menu @node Stack Overflow Checking,Static Stack Usage Analysis,,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1c4}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{f4} +@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1a9}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{e5} @subsection Stack Overflow Checking @@ -23213,7 +21858,7 @@ If the space is exceeded, then a @code{Storage_Error} exception is raised. For declared tasks, the default stack size is defined by the GNAT runtime, whose size may be modified at bind time through the @code{-d} bind switch -(@ref{11f,,Switches for gnatbind}). Task specific stack sizes may be set using the +(@ref{110,,Switches for gnatbind}). Task specific stack sizes may be set using the @code{Storage_Size} pragma. For the environment task, the stack size is determined by the operating system. @@ -23221,7 +21866,7 @@ Consequently, to modify the size of the environment task please refer to your operating system documentation. @node Static Stack Usage Analysis,Dynamic Stack Usage Analysis,Stack Overflow Checking,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1c5}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{f5} +@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1aa}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{e6} @subsection Static Stack Usage Analysis @@ -23270,7 +21915,7 @@ subprogram whose stack usage might be larger than the specified amount of bytes. The wording is in keeping with the qualifier documented above. @node Dynamic Stack Usage Analysis,,Static Stack Usage Analysis,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1c6}@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{122} +@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1ab}@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{113} @subsection Dynamic Stack Usage Analysis @@ -23352,7 +21997,7 @@ The package @code{GNAT.Task_Stack_Usage} provides facilities to get stack-usage reports at run time. See its body for the details. @node Memory Management Issues,,Stack Related Facilities,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{2a} +@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{14c}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{1ac} @section Memory Management Issues @@ -23368,7 +22013,7 @@ incorrect uses of access values (including 'dangling references'). @end menu @node Some Useful Memory Pools,The GNAT Debug Pool Facility,,Memory Management Issues -@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1c7}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1c8} +@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1ad}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1ae} @subsection Some Useful Memory Pools @@ -23449,7 +22094,7 @@ for T1'Storage_Size use 10_000; @end quotation @node The GNAT Debug Pool Facility,,Some Useful Memory Pools,Memory Management Issues -@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1c9}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1ca} +@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1b0} @subsection The GNAT Debug Pool Facility @@ -23612,7 +22257,7 @@ Debug Pool info: @c -- E.g. Ada |nbsp| 95 @node Platform-Specific Information,Example of Binder Output File,GNAT and Program Execution,Top -@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d}@anchor{gnat_ugn/platform_specific_information doc}@anchor{1cb}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1cc} +@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d}@anchor{gnat_ugn/platform_specific_information doc}@anchor{1b1}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1b2} @chapter Platform-Specific Information @@ -23630,7 +22275,7 @@ topics related to the GNAT implementation on Windows and Mac OS. @end menu @node Run-Time Libraries,Specifying a Run-Time Library,,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information id2}@anchor{1cd}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{2b} +@anchor{gnat_ugn/platform_specific_information id2}@anchor{1b3}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{1b4} @section Run-Time Libraries @@ -23691,7 +22336,7 @@ are supplied on various GNAT platforms. @end menu @node Summary of Run-Time Configurations,,,Run-Time Libraries -@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1ce}@anchor{gnat_ugn/platform_specific_information id3}@anchor{1cf} +@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1b5}@anchor{gnat_ugn/platform_specific_information id3}@anchor{1b6} @subsection Summary of Run-Time Configurations @@ -23791,7 +22436,7 @@ ZCX @node Specifying a Run-Time Library,GNU/Linux Topics,Run-Time Libraries,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1d0}@anchor{gnat_ugn/platform_specific_information id4}@anchor{1d1} +@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1b7}@anchor{gnat_ugn/platform_specific_information id4}@anchor{1b8} @section Specifying a Run-Time Library @@ -23878,7 +22523,7 @@ Alternatively, you can specify @code{rts-sjlj/adainclude} in the file Selecting another run-time library temporarily can be achieved by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj} -@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1d2} +@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1b9} @geindex SCHED_FIFO scheduling policy @geindex SCHED_RR scheduling policy @@ -23891,7 +22536,7 @@ achieved by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj} @end menu @node Choosing the Scheduling Policy,,,Specifying a Run-Time Library -@anchor{gnat_ugn/platform_specific_information id5}@anchor{1d3} +@anchor{gnat_ugn/platform_specific_information id5}@anchor{1ba} @subsection Choosing the Scheduling Policy @@ -23950,7 +22595,7 @@ Program_Error. @geindex GNU/Linux @node GNU/Linux Topics,Microsoft Windows Topics,Specifying a Run-Time Library,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information id6}@anchor{1d4}@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1d5} +@anchor{gnat_ugn/platform_specific_information id6}@anchor{1bb}@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1bc} @section GNU/Linux Topics @@ -23962,7 +22607,7 @@ This section describes topics that are specific to GNU/Linux platforms. @end menu @node Required Packages on GNU/Linux,,,GNU/Linux Topics -@anchor{gnat_ugn/platform_specific_information id7}@anchor{1d6}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1d7} +@anchor{gnat_ugn/platform_specific_information id7}@anchor{1bd}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1be} @subsection Required Packages on GNU/Linux @@ -23998,7 +22643,7 @@ for those packages. @geindex Windows @node Microsoft Windows Topics,Mac OS Topics,GNU/Linux Topics,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{2c}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1d8} +@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{1bf}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1c0} @section Microsoft Windows Topics @@ -24019,7 +22664,7 @@ platforms. @end menu @node Using GNAT on Windows,Using a network installation of GNAT,,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1d9}@anchor{gnat_ugn/platform_specific_information id9}@anchor{1da} +@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1c1}@anchor{gnat_ugn/platform_specific_information id9}@anchor{1c2} @subsection Using GNAT on Windows @@ -24096,7 +22741,7 @@ uninstall or integrate different GNAT products. @end itemize @node Using a network installation of GNAT,CONSOLE and WINDOWS subsystems,Using GNAT on Windows,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id10}@anchor{1db}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1dc} +@anchor{gnat_ugn/platform_specific_information id10}@anchor{1c3}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1c4} @subsection Using a network installation of GNAT @@ -24123,7 +22768,7 @@ transfer of large amounts of data across the network and will likely cause serious performance penalty. @node CONSOLE and WINDOWS subsystems,Temporary Files,Using a network installation of GNAT,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id11}@anchor{1dd}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1de} +@anchor{gnat_ugn/platform_specific_information id11}@anchor{1c5}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1c6} @subsection CONSOLE and WINDOWS subsystems @@ -24148,7 +22793,7 @@ $ gnatmake winprog -largs -mwindows @end quotation @node Temporary Files,Disabling Command Line Argument Expansion,CONSOLE and WINDOWS subsystems,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id12}@anchor{1df}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1e0} +@anchor{gnat_ugn/platform_specific_information id12}@anchor{1c7}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1c8} @subsection Temporary Files @@ -24187,7 +22832,7 @@ environments where you may not have write access to some directories. @node Disabling Command Line Argument Expansion,Windows Socket Timeouts,Temporary Files,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1e1} +@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1c9} @subsection Disabling Command Line Argument Expansion @@ -24258,7 +22903,7 @@ Ada.Command_Line.Argument (1) -> "'*.txt'" @end example @node Windows Socket Timeouts,Mixed-Language Programming on Windows,Disabling Command Line Argument Expansion,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1e2} +@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1ca} @subsection Windows Socket Timeouts @@ -24304,7 +22949,7 @@ shorter than 500 ms is needed on these Windows versions, a call to Check_Selector should be added before any socket read or write operations. @node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Windows Socket Timeouts,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id13}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1e4} +@anchor{gnat_ugn/platform_specific_information id13}@anchor{1cb}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1cc} @subsection Mixed-Language Programming on Windows @@ -24326,17 +22971,17 @@ to use the Microsoft tools for your C++ code, you have two choices: Encapsulate your C++ code in a DLL to be linked with your Ada application. In this case, use the Microsoft or whatever environment to build the DLL and use GNAT to build your executable -(@ref{1e5,,Using DLLs with GNAT}). +(@ref{1cd,,Using DLLs with GNAT}). @item Or you can encapsulate your Ada code in a DLL to be linked with the other part of your application. In this case, use GNAT to build the DLL -(@ref{1e6,,Building DLLs with GNAT Project files}) and use the Microsoft +(@ref{1ce,,Building DLLs with GNAT Project files}) and use the Microsoft or whatever environment to build your executable. @end itemize In addition to the description about C main in -@ref{44,,Mixed Language Programming} section, if the C main uses a +@ref{2c,,Mixed Language Programming} section, if the C main uses a stand-alone library it is required on x86-windows to setup the SEH context. For this the C main must looks like this: @@ -24388,7 +23033,7 @@ native SEH support is used. @end menu @node Windows Calling Conventions,Introduction to Dynamic Link Libraries DLLs,,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1e7}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1e8} +@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1cf}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1d0} @subsubsection Windows Calling Conventions @@ -24433,7 +23078,7 @@ are available for Windows: @end menu @node C Calling Convention,Stdcall Calling Convention,,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1e9}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1ea} +@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1d1}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1d2} @subsubsection @code{C} Calling Convention @@ -24475,10 +23120,10 @@ is missing, as in the above example, this parameter is set to be the When importing a variable defined in C, you should always use the @code{C} calling convention unless the object containing the variable is part of a DLL (in which case you should use the @code{Stdcall} calling -convention, @ref{1eb,,Stdcall Calling Convention}). +convention, @ref{1d3,,Stdcall Calling Convention}). @node Stdcall Calling Convention,Win32 Calling Convention,C Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1eb}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1ec} +@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1d3}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1d4} @subsubsection @code{Stdcall} Calling Convention @@ -24575,7 +23220,7 @@ Note that to ease building cross-platform bindings this convention will be handled as a @code{C} calling convention on non-Windows platforms. @node Win32 Calling Convention,DLL Calling Convention,Stdcall Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1ed}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1ee} +@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1d5}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1d6} @subsubsection @code{Win32} Calling Convention @@ -24583,7 +23228,7 @@ This convention, which is GNAT-specific is fully equivalent to the @code{Stdcall} calling convention described above. @node DLL Calling Convention,,Win32 Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information id18}@anchor{1ef}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1f0} +@anchor{gnat_ugn/platform_specific_information id18}@anchor{1d7}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1d8} @subsubsection @code{DLL} Calling Convention @@ -24591,7 +23236,7 @@ This convention, which is GNAT-specific is fully equivalent to the @code{Stdcall} calling convention described above. @node Introduction to Dynamic Link Libraries DLLs,Using DLLs with GNAT,Windows Calling Conventions,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id19}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1f2} +@anchor{gnat_ugn/platform_specific_information id19}@anchor{1d9}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1da} @subsubsection Introduction to Dynamic Link Libraries (DLLs) @@ -24675,10 +23320,10 @@ As a side note, an interesting difference between Microsoft DLLs and Unix shared libraries, is the fact that on most Unix systems all public routines are exported by default in a Unix shared library, while under Windows it is possible (but not required) to list exported routines in -a definition file (see @ref{1f3,,The Definition File}). +a definition file (see @ref{1db,,The Definition File}). @node Using DLLs with GNAT,Building DLLs with GNAT Project files,Introduction to Dynamic Link Libraries DLLs,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id20}@anchor{1f4}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1e5} +@anchor{gnat_ugn/platform_specific_information id20}@anchor{1dc}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1cd} @subsubsection Using DLLs with GNAT @@ -24769,7 +23414,7 @@ example a fictitious DLL called @code{API.dll}. @end menu @node Creating an Ada Spec for the DLL Services,Creating an Import Library,,Using DLLs with GNAT -@anchor{gnat_ugn/platform_specific_information id21}@anchor{1f5}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1f6} +@anchor{gnat_ugn/platform_specific_information id21}@anchor{1dd}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1de} @subsubsection Creating an Ada Spec for the DLL Services @@ -24809,7 +23454,7 @@ end API; @end quotation @node Creating an Import Library,,Creating an Ada Spec for the DLL Services,Using DLLs with GNAT -@anchor{gnat_ugn/platform_specific_information id22}@anchor{1f7}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1f8} +@anchor{gnat_ugn/platform_specific_information id22}@anchor{1df}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1e0} @subsubsection Creating an Import Library @@ -24823,7 +23468,7 @@ as in this case it is possible to link directly against the DLL. Otherwise read on. @geindex Definition file -@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1f3} +@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1db} @subsubheading The Definition File @@ -24871,17 +23516,17 @@ EXPORTS @end table Note that you must specify the correct suffix (@code{@@@emph{nn}}) -(see @ref{1e7,,Windows Calling Conventions}) for a Stdcall +(see @ref{1cf,,Windows Calling Conventions}) for a Stdcall calling convention function in the exported symbols list. There can actually be other sections in a definition file, but these sections are not relevant to the discussion at hand. -@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1f9} +@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1e1} @subsubheading Creating a Definition File Automatically You can automatically create the definition file @code{API.def} -(see @ref{1f3,,The Definition File}) from a DLL. +(see @ref{1db,,The Definition File}) from a DLL. For that use the @code{dlltool} program as follows: @quotation @@ -24891,7 +23536,7 @@ $ dlltool API.dll -z API.def --export-all-symbols @end example Note that if some routines in the DLL have the @code{Stdcall} convention -(@ref{1e7,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}} +(@ref{1cf,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}} suffix then you'll have to edit @code{api.def} to add it, and specify @code{-k} to @code{gnatdll} when creating the import library. @@ -24915,13 +23560,13 @@ tells you what symbol is expected. You just have to go back to the definition file and add the right suffix. @end itemize @end quotation -@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1fa} +@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1e2} @subsubheading GNAT-Style Import Library To create a static import library from @code{API.dll} with the GNAT tools you should create the .def file, then use @code{gnatdll} tool -(see @ref{1fb,,Using gnatdll}) as follows: +(see @ref{1e3,,Using gnatdll}) as follows: @quotation @@ -24937,15 +23582,15 @@ definition file name is @code{xyz.def}, the import library name will be @code{libxyz.a}. Note that in the previous example option @code{-e} could have been removed because the name of the definition file (before the @code{.def} suffix) is the same as the name of the -DLL (@ref{1fb,,Using gnatdll} for more information about @code{gnatdll}). +DLL (@ref{1e3,,Using gnatdll} for more information about @code{gnatdll}). @end quotation -@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1fc} +@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1e4} @subsubheading Microsoft-Style Import Library A Microsoft import library is needed only if you plan to make an Ada DLL available to applications developed with Microsoft -tools (@ref{1e4,,Mixed-Language Programming on Windows}). +tools (@ref{1cc,,Mixed-Language Programming on Windows}). To create a Microsoft-style import library for @code{API.dll} you should create the .def file, then build the actual import library using @@ -24969,7 +23614,7 @@ See the Microsoft documentation for further details about the usage of @end quotation @node Building DLLs with GNAT Project files,Building DLLs with GNAT,Using DLLs with GNAT,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id23}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1e6} +@anchor{gnat_ugn/platform_specific_information id23}@anchor{1e5}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1ce} @subsubsection Building DLLs with GNAT Project files @@ -24985,7 +23630,7 @@ when inside the @code{DllMain} routine which is used for auto-initialization of shared libraries, so it is not possible to have library level tasks in SALs. @node Building DLLs with GNAT,Building DLLs with gnatdll,Building DLLs with GNAT Project files,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1fe}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1ff} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1e6}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1e7} @subsubsection Building DLLs with GNAT @@ -25016,7 +23661,7 @@ $ gcc -shared -shared-libgcc -o api.dll obj1.o obj2.o ... It is important to note that in this case all symbols found in the object files are automatically exported. It is possible to restrict the set of symbols to export by passing to @code{gcc} a definition -file (see @ref{1f3,,The Definition File}). +file (see @ref{1db,,The Definition File}). For example: @example @@ -25054,7 +23699,7 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI @end quotation @node Building DLLs with gnatdll,Ada DLLs and Finalization,Building DLLs with GNAT,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{200}@anchor{gnat_ugn/platform_specific_information id25}@anchor{201} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{1e8}@anchor{gnat_ugn/platform_specific_information id25}@anchor{1e9} @subsubsection Building DLLs with gnatdll @@ -25062,8 +23707,8 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI @geindex building Note that it is preferred to use GNAT Project files -(@ref{1e6,,Building DLLs with GNAT Project files}) or the built-in GNAT -DLL support (@ref{1fe,,Building DLLs with GNAT}) or to build DLLs. +(@ref{1ce,,Building DLLs with GNAT Project files}) or the built-in GNAT +DLL support (@ref{1e6,,Building DLLs with GNAT}) or to build DLLs. This section explains how to build DLLs containing Ada code using @code{gnatdll}. These DLLs will be referred to as Ada DLLs in the @@ -25079,20 +23724,20 @@ non-Ada applications are as follows: You need to mark each Ada entity exported by the DLL with a @code{C} or @code{Stdcall} calling convention to avoid any Ada name mangling for the entities exported by the DLL -(see @ref{202,,Exporting Ada Entities}). You can +(see @ref{1ea,,Exporting Ada Entities}). You can skip this step if you plan to use the Ada DLL only from Ada applications. @item Your Ada code must export an initialization routine which calls the routine @code{adainit} generated by @code{gnatbind} to perform the elaboration of -the Ada code in the DLL (@ref{203,,Ada DLLs and Elaboration}). The initialization +the Ada code in the DLL (@ref{1eb,,Ada DLLs and Elaboration}). The initialization routine exported by the Ada DLL must be invoked by the clients of the DLL to initialize the DLL. @item When useful, the DLL should also export a finalization routine which calls routine @code{adafinal} generated by @code{gnatbind} to perform the -finalization of the Ada code in the DLL (@ref{204,,Ada DLLs and Finalization}). +finalization of the Ada code in the DLL (@ref{1ec,,Ada DLLs and Finalization}). The finalization routine exported by the Ada DLL must be invoked by the clients of the DLL when the DLL services are no further needed. @@ -25102,11 +23747,11 @@ of the programming languages to which you plan to make the DLL available. @item You must provide a definition file listing the exported entities -(@ref{1f3,,The Definition File}). +(@ref{1db,,The Definition File}). @item Finally you must use @code{gnatdll} to produce the DLL and the import -library (@ref{1fb,,Using gnatdll}). +library (@ref{1e3,,Using gnatdll}). @end itemize Note that a relocatable DLL stripped using the @code{strip} @@ -25126,7 +23771,7 @@ chapter of the @emph{GPRbuild User's Guide}. @end menu @node Limitations When Using Ada DLLs from Ada,Exporting Ada Entities,,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{205} +@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{1ed} @subsubsection Limitations When Using Ada DLLs from Ada @@ -25147,7 +23792,7 @@ It is completely safe to exchange plain elementary, array or record types, Windows object handles, etc. @node Exporting Ada Entities,Ada DLLs and Elaboration,Limitations When Using Ada DLLs from Ada,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{202}@anchor{gnat_ugn/platform_specific_information id26}@anchor{206} +@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{1ea}@anchor{gnat_ugn/platform_specific_information id26}@anchor{1ee} @subsubsection Exporting Ada Entities @@ -25247,10 +23892,10 @@ end API; Note that if you do not export the Ada entities with a @code{C} or @code{Stdcall} convention you will have to provide the mangled Ada names in the definition file of the Ada DLL -(@ref{207,,Creating the Definition File}). +(@ref{1ef,,Creating the Definition File}). @node Ada DLLs and Elaboration,,Exporting Ada Entities,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{203}@anchor{gnat_ugn/platform_specific_information id27}@anchor{208} +@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{1eb}@anchor{gnat_ugn/platform_specific_information id27}@anchor{1f0} @subsubsection Ada DLLs and Elaboration @@ -25265,10 +23910,10 @@ To achieve this you must export an initialization routine (@code{Initialize_API} in the previous example), which must be invoked before using any of the DLL services. This elaboration routine must call the Ada elaboration routine @code{adainit} generated by the GNAT binder -(@ref{b4,,Binding with Non-Ada Main Programs}). See the body of +(@ref{a0,,Binding with Non-Ada Main Programs}). See the body of @code{Initialize_Api} for an example. Note that the GNAT binder is automatically invoked during the DLL build process by the @code{gnatdll} -tool (@ref{1fb,,Using gnatdll}). +tool (@ref{1e3,,Using gnatdll}). When a DLL is loaded, Windows systematically invokes a routine called @code{DllMain}. It would therefore be possible to call @code{adainit} @@ -25281,7 +23926,7 @@ time), which means that the GNAT run-time will deadlock waiting for the newly created task to complete its initialization. @node Ada DLLs and Finalization,Creating a Spec for Ada DLLs,Building DLLs with gnatdll,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id28}@anchor{209}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{204} +@anchor{gnat_ugn/platform_specific_information id28}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{1ec} @subsubsection Ada DLLs and Finalization @@ -25292,14 +23937,14 @@ invoke the DLL finalization routine, if available. The DLL finalization routine is in charge of releasing all resources acquired by the DLL. In the case of the Ada code contained in the DLL, this is achieved by calling routine @code{adafinal} generated by the GNAT binder -(@ref{b4,,Binding with Non-Ada Main Programs}). +(@ref{a0,,Binding with Non-Ada Main Programs}). See the body of @code{Finalize_Api} for an example. As already pointed out the GNAT binder is automatically invoked during the DLL build process by the @code{gnatdll} tool -(@ref{1fb,,Using gnatdll}). +(@ref{1e3,,Using gnatdll}). @node Creating a Spec for Ada DLLs,GNAT and Windows Resources,Ada DLLs and Finalization,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id29}@anchor{20a}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{20b} +@anchor{gnat_ugn/platform_specific_information id29}@anchor{1f2}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{1f3} @subsubsection Creating a Spec for Ada DLLs @@ -25357,7 +24002,7 @@ end API; @end menu @node Creating the Definition File,Using gnatdll,,Creating a Spec for Ada DLLs -@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{207}@anchor{gnat_ugn/platform_specific_information id30}@anchor{20c} +@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{1ef}@anchor{gnat_ugn/platform_specific_information id30}@anchor{1f4} @subsubsection Creating the Definition File @@ -25393,7 +24038,7 @@ EXPORTS @end quotation @node Using gnatdll,,Creating the Definition File,Creating a Spec for Ada DLLs -@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1fb}@anchor{gnat_ugn/platform_specific_information id31}@anchor{20d} +@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information id31}@anchor{1f5} @subsubsection Using @code{gnatdll} @@ -25491,7 +24136,7 @@ Help mode. Displays @code{gnatdll} switch usage information. Direct @code{gnatdll} to search the @code{dir} directory for source and object files needed to build the DLL. -(@ref{89,,Search Paths and the Run-Time Library (RTL)}). +(@ref{73,,Search Paths and the Run-Time Library (RTL)}). @geindex -k (gnatdll) @@ -25604,7 +24249,7 @@ asks @code{gnatlink} to generate the routines @code{DllMain} and is loaded into memory. @item -@code{gnatdll} uses @code{dlltool} (see @ref{20e,,Using dlltool}) to build the +@code{gnatdll} uses @code{dlltool} (see @ref{1f6,,Using dlltool}) to build the export table (@code{api.exp}). The export table contains the relocation information in a form which can be used during the final link to ensure that the Windows loader is able to place the DLL anywhere in memory. @@ -25643,7 +24288,7 @@ $ gnatbind -n api $ gnatlink api api.exp -o api.dll -mdll @end example @end itemize -@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{20e} +@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{1f6} @subsubheading Using @code{dlltool} @@ -25702,7 +24347,7 @@ DLL in the static import library generated by @code{dlltool} with switch @item @code{-k} Kill @code{@@@emph{nn}} from exported names -(@ref{1e7,,Windows Calling Conventions} +(@ref{1cf,,Windows Calling Conventions} for a discussion about @code{Stdcall}-style symbols. @end table @@ -25758,7 +24403,7 @@ Use @code{assembler-name} as the assembler. The default is @code{as}. @end table @node GNAT and Windows Resources,Using GNAT DLLs from Microsoft Visual Studio Applications,Creating a Spec for Ada DLLs,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{20f}@anchor{gnat_ugn/platform_specific_information id32}@anchor{210} +@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{1f7}@anchor{gnat_ugn/platform_specific_information id32}@anchor{1f8} @subsubsection GNAT and Windows Resources @@ -25853,7 +24498,7 @@ the corresponding Microsoft documentation. @end menu @node Building Resources,Compiling Resources,,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{211}@anchor{gnat_ugn/platform_specific_information id33}@anchor{212} +@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{1f9}@anchor{gnat_ugn/platform_specific_information id33}@anchor{1fa} @subsubsection Building Resources @@ -25873,7 +24518,7 @@ complete description of the resource script language can be found in the Microsoft documentation. @node Compiling Resources,Using Resources,Building Resources,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{213}@anchor{gnat_ugn/platform_specific_information id34}@anchor{214} +@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{1fb}@anchor{gnat_ugn/platform_specific_information id34}@anchor{1fc} @subsubsection Compiling Resources @@ -25915,7 +24560,7 @@ $ windres -i myres.res -o myres.o @end quotation @node Using Resources,,Compiling Resources,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{215}@anchor{gnat_ugn/platform_specific_information id35}@anchor{216} +@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information id35}@anchor{1fe} @subsubsection Using Resources @@ -25935,7 +24580,7 @@ $ gnatmake myprog -largs myres.o @end quotation @node Using GNAT DLLs from Microsoft Visual Studio Applications,Debugging a DLL,GNAT and Windows Resources,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{217}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{218} +@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{1ff}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{200} @subsubsection Using GNAT DLLs from Microsoft Visual Studio Applications @@ -25969,7 +24614,7 @@ $ gprbuild -p mylib.gpr @item Produce a .def file for the symbols you need to interface with, either by hand or automatically with possibly some manual adjustments -(see @ref{1f9,,Creating Definition File Automatically}): +(see @ref{1e1,,Creating Definition File Automatically}): @end enumerate @quotation @@ -25986,7 +24631,7 @@ $ dlltool libmylib.dll -z libmylib.def --export-all-symbols Make sure that MSVS command-line tools are accessible on the path. @item -Create the Microsoft-style import library (see @ref{1fc,,MSVS-Style Import Library}): +Create the Microsoft-style import library (see @ref{1e4,,MSVS-Style Import Library}): @end enumerate @quotation @@ -26028,7 +24673,7 @@ or copy the DLL into into the directory containing the .exe. @end enumerate @node Debugging a DLL,Setting Stack Size from gnatlink,Using GNAT DLLs from Microsoft Visual Studio Applications,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id36}@anchor{219}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{21a} +@anchor{gnat_ugn/platform_specific_information id36}@anchor{201}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{202} @subsubsection Debugging a DLL @@ -26066,7 +24711,7 @@ tools suite used to build the DLL. @end menu @node Program and DLL Both Built with GCC/GNAT,Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Debugging a DLL -@anchor{gnat_ugn/platform_specific_information id37}@anchor{21b}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{21c} +@anchor{gnat_ugn/platform_specific_information id37}@anchor{203}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{204} @subsubsection Program and DLL Both Built with GCC/GNAT @@ -26076,7 +24721,7 @@ the process. Let's suppose here that the main procedure is named @code{ada_main} and that in the DLL there is an entry point named @code{ada_dll}. -The DLL (@ref{1f2,,Introduction to Dynamic Link Libraries (DLLs)}) and +The DLL (@ref{1da,,Introduction to Dynamic Link Libraries (DLLs)}) and program must have been built with the debugging information (see GNAT -g switch). Here are the step-by-step instructions for debugging it: @@ -26113,10 +24758,10 @@ Set a breakpoint inside the DLL At this stage a breakpoint is set inside the DLL. From there on you can use the standard approach to debug the whole program -(@ref{24,,Running and Debugging Ada Programs}). +(@ref{14d,,Running and Debugging Ada Programs}). @node Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Program and DLL Both Built with GCC/GNAT,Debugging a DLL -@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{21d}@anchor{gnat_ugn/platform_specific_information id38}@anchor{21e} +@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{205}@anchor{gnat_ugn/platform_specific_information id38}@anchor{206} @subsubsection Program Built with Foreign Tools and DLL Built with GCC/GNAT @@ -26133,7 +24778,7 @@ example some C code built with Microsoft Visual C) and that there is a DLL named @code{test.dll} containing an Ada entry point named @code{ada_dll}. -The DLL (see @ref{1f2,,Introduction to Dynamic Link Libraries (DLLs)}) must have +The DLL (see @ref{1da,,Introduction to Dynamic Link Libraries (DLLs)}) must have been built with debugging information (see the GNAT @code{-g} option). @subsubheading Debugging the DLL Directly @@ -26199,7 +24844,7 @@ Continue the program. This will run the program until it reaches the breakpoint that has been set. From that point you can use the standard way to debug a program -as described in (@ref{24,,Running and Debugging Ada Programs}). +as described in (@ref{14d,,Running and Debugging Ada Programs}). @end itemize It is also possible to debug the DLL by attaching to a running process. @@ -26269,10 +24914,10 @@ Continue process execution. This last step will resume the process execution, and stop at the breakpoint we have set. From there you can use the standard approach to debug a program as described in -@ref{24,,Running and Debugging Ada Programs}. +@ref{14d,,Running and Debugging Ada Programs}. @node Setting Stack Size from gnatlink,Setting Heap Size from gnatlink,Debugging a DLL,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{136}@anchor{gnat_ugn/platform_specific_information id39}@anchor{21f} +@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{127}@anchor{gnat_ugn/platform_specific_information id39}@anchor{207} @subsubsection Setting Stack Size from @code{gnatlink} @@ -26315,7 +24960,7 @@ because the comma is a separator for this option. @end itemize @node Setting Heap Size from gnatlink,,Setting Stack Size from gnatlink,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{137}@anchor{gnat_ugn/platform_specific_information id40}@anchor{220} +@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{128}@anchor{gnat_ugn/platform_specific_information id40}@anchor{208} @subsubsection Setting Heap Size from @code{gnatlink} @@ -26348,7 +24993,7 @@ because the comma is a separator for this option. @end itemize @node Windows Specific Add-Ons,,Mixed-Language Programming on Windows,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{221}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{222} +@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{209}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{20a} @subsection Windows Specific Add-Ons @@ -26361,7 +25006,7 @@ This section describes the Windows specific add-ons. @end menu @node Win32Ada,wPOSIX,,Windows Specific Add-Ons -@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{223}@anchor{gnat_ugn/platform_specific_information id41}@anchor{224} +@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{20b}@anchor{gnat_ugn/platform_specific_information id41}@anchor{20c} @subsubsection Win32Ada @@ -26392,7 +25037,7 @@ gprbuild p.gpr @end quotation @node wPOSIX,,Win32Ada,Windows Specific Add-Ons -@anchor{gnat_ugn/platform_specific_information id42}@anchor{225}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{226} +@anchor{gnat_ugn/platform_specific_information id42}@anchor{20d}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{20e} @subsubsection wPOSIX @@ -26425,7 +25070,7 @@ gprbuild p.gpr @end quotation @node Mac OS Topics,,Microsoft Windows Topics,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{2d}@anchor{gnat_ugn/platform_specific_information id43}@anchor{227} +@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{20f}@anchor{gnat_ugn/platform_specific_information id43}@anchor{210} @section Mac OS Topics @@ -26440,7 +25085,7 @@ platform. @end menu @node Codesigning the Debugger,,,Mac OS Topics -@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{228} +@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{211} @subsection Codesigning the Debugger @@ -26521,7 +25166,7 @@ the location where you installed GNAT. Also, be sure that users are in the Unix group @code{_developer}. @node Example of Binder Output File,Elaboration Order Handling in GNAT,Platform-Specific Information,Top -@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{229}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{22a} +@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{212}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{213} @chapter Example of Binder Output File @@ -27273,7 +25918,7 @@ elaboration code in your own application). @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node Elaboration Order Handling in GNAT,Inline Assembler,Example of Binder Output File,Top -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{22b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{22c} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{214}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{215} @chapter Elaboration Order Handling in GNAT @@ -27303,7 +25948,7 @@ GNAT, either automatically or with explicit programming features. @end menu @node Elaboration Code,Elaboration Order,,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{22d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{22e} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{216}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{217} @section Elaboration Code @@ -27451,7 +26096,7 @@ elaborated. @end itemize @node Elaboration Order,Checking the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{22f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{230} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{218}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{219} @section Elaboration Order @@ -27620,7 +26265,7 @@ however a compiler may not always find such an order due to complications with respect to control and data flow. @node Checking the Elaboration Order,Controlling the Elaboration Order in Ada,Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{231}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{232} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{21a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{21b} @section Checking the Elaboration Order @@ -27681,7 +26326,7 @@ order. @end itemize @node Controlling the Elaboration Order in Ada,Controlling the Elaboration Order in GNAT,Checking the Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{233}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{234} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{21c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{21d} @section Controlling the Elaboration Order in Ada @@ -28009,7 +26654,7 @@ is that the program continues to stay in the last state (one or more correct orders exist) even if maintenance changes the bodies of targets. @node Controlling the Elaboration Order in GNAT,Mixing Elaboration Models,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{235}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{236} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{21e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{21f} @section Controlling the Elaboration Order in GNAT @@ -28139,7 +26784,7 @@ The dynamic, legacy, and static models can be relaxed using compiler switch may not diagnose certain elaboration issues or install run-time checks. @node Mixing Elaboration Models,ABE Diagnostics,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{237}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{238} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{220}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{221} @section Mixing Elaboration Models @@ -28186,7 +26831,7 @@ warning: "y.ads" which has static elaboration checks The warnings can be suppressed by binder switch @code{-ws}. @node ABE Diagnostics,SPARK Diagnostics,Mixing Elaboration Models,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{239}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{23a} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{222}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{223} @section ABE Diagnostics @@ -28293,7 +26938,7 @@ declaration @code{Safe} because the body of function @code{ABE} has already been elaborated at that point. @node SPARK Diagnostics,Elaboration Circularities,ABE Diagnostics,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{23b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23c} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{224}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{225} @section SPARK Diagnostics @@ -28319,7 +26964,7 @@ rules. @end quotation @node Elaboration Circularities,Resolving Elaboration Circularities,SPARK Diagnostics,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{23e} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{226}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{227} @section Elaboration Circularities @@ -28419,7 +27064,7 @@ This section enumerates various tactics for eliminating the circularity. @end itemize @node Resolving Elaboration Circularities,Elaboration-related Compiler Switches,Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{23f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{240} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{228}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{229} @section Resolving Elaboration Circularities @@ -28690,7 +27335,7 @@ Use the relaxed dynamic-elaboration model, with compiler switches @end itemize @node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{241}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{242} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{22b} @section Elaboration-related Compiler Switches @@ -28871,7 +27516,7 @@ checks. The example above will still fail at run time with an ABE. @end table @node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{243}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{244} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{22c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{22d} @section Summary of Procedures for Elaboration Control @@ -28929,7 +27574,7 @@ Use the relaxed dynamic elaboration model, with compiler switches @end itemize @node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{245}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{246} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{22f} @section Inspecting the Chosen Elaboration Order @@ -29072,7 +27717,7 @@ gdbstr (body) @end quotation @node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top -@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{247}@anchor{gnat_ugn/inline_assembler id1}@anchor{248} +@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{230}@anchor{gnat_ugn/inline_assembler id1}@anchor{231} @chapter Inline Assembler @@ -29131,7 +27776,7 @@ and with assembly language programming. @end menu @node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler -@anchor{gnat_ugn/inline_assembler id2}@anchor{249}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{24a} +@anchor{gnat_ugn/inline_assembler id2}@anchor{232}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{233} @section Basic Assembler Syntax @@ -29247,7 +27892,7 @@ Intel: Destination first; for example @code{mov eax, 4}@w{ } @node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler -@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{24b}@anchor{gnat_ugn/inline_assembler id3}@anchor{24c} +@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{234}@anchor{gnat_ugn/inline_assembler id3}@anchor{235} @section A Simple Example of Inline Assembler @@ -29396,7 +28041,7 @@ If there are no errors, @code{as} will generate an object file @code{nothing.out}. @node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id4}@anchor{24d}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{24e} +@anchor{gnat_ugn/inline_assembler id4}@anchor{236}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{237} @section Output Variables in Inline Assembler @@ -29763,7 +28408,7 @@ end Get_Flags_3; @end quotation @node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id5}@anchor{24f}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{250} +@anchor{gnat_ugn/inline_assembler id5}@anchor{238}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{239} @section Input Variables in Inline Assembler @@ -29852,7 +28497,7 @@ _increment__incr.1: @end quotation @node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id6}@anchor{251}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{252} +@anchor{gnat_ugn/inline_assembler id6}@anchor{23a}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{23b} @section Inlining Inline Assembler Code @@ -29923,7 +28568,7 @@ movl %esi,%eax thus saving the overhead of stack frame setup and an out-of-line call. @node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler -@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{253}@anchor{gnat_ugn/inline_assembler id7}@anchor{254} +@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{23c}@anchor{gnat_ugn/inline_assembler id7}@anchor{23d} @section Other @code{Asm} Functionality @@ -29938,7 +28583,7 @@ and @code{Volatile}, which inhibits unwanted optimizations. @end menu @node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{255}@anchor{gnat_ugn/inline_assembler id8}@anchor{256} +@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{23e}@anchor{gnat_ugn/inline_assembler id8}@anchor{23f} @subsection The @code{Clobber} Parameter @@ -30002,7 +28647,7 @@ Use 'register' name @code{memory} if you changed a memory location @end itemize @node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{257}@anchor{gnat_ugn/inline_assembler id9}@anchor{258} +@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{240}@anchor{gnat_ugn/inline_assembler id9}@anchor{241} @subsection The @code{Volatile} Parameter @@ -30038,7 +28683,7 @@ to @code{True} only if the compiler's optimizations have created problems. @node GNU Free Documentation License,Index,Inline Assembler,Top -@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{259}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{25a} +@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{242}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{243} @chapter GNU Free Documentation License @@ -30526,8 +29171,8 @@ to permit their use in free software. @printindex ge -@anchor{de}@w{ } @anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } +@anchor{cf}@w{ } @c %**end of body @bye diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 4372152..be087af 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -238,8 +238,8 @@ procedure Gnatbind is ------------------------------ function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean is - CR : Restrictions_Info renames Cumulative_Restrictions; - + CR : Restrictions_Info renames Cumulative_Restrictions; + Result : Boolean; begin case R is @@ -247,11 +247,19 @@ procedure Gnatbind is when All_Boolean_Restrictions => - -- The condition for listing a boolean restriction as an - -- additional restriction that could be set is that it is - -- not violated by any unit, and not already set. + -- Print it if not violated by any unit, and not already set... + + Result := not CR.Violated (R) and then not CR.Set (R); + + -- ...except that for No_Tasks_Unassigned_To_CPU, we don't want + -- to print it if it would violate the restriction post + -- compilation. - return CR.Violated (R) = False and then CR.Set (R) = False; + if R = No_Tasks_Unassigned_To_CPU + and then ALIs.Table (ALIs.First).Main_CPU = No_Main_CPU + then + Result := False; + end if; -- Parameter restriction @@ -261,18 +269,18 @@ procedure Gnatbind is -- unknown, the restriction can definitely not be listed. if CR.Violated (R) and then CR.Unknown (R) then - return False; + Result := False; -- We can list the restriction if it is not set elsif not CR.Set (R) then - return True; + Result := True; -- We can list the restriction if is set to a greater value -- than the maximum value known for the violation. else - return CR.Value (R) > CR.Count (R); + Result := CR.Value (R) > CR.Count (R); end if; -- No other values for R possible @@ -280,6 +288,8 @@ procedure Gnatbind is when others => raise Program_Error; end case; + + return Result; end Restriction_Could_Be_Set; -- Start of processing for List_Applicable_Restrictions @@ -881,6 +891,17 @@ begin -- mode where we want to be more flexible. if not CodePeer_Mode then + -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU": + -- If the restriction No_Tasks_Unassigned_To_CPU applies, then + -- check that the main subprogram has a CPU assigned. + + if Cumulative_Restrictions.Set (No_Tasks_Unassigned_To_CPU) + and then ALIs.Table (ALIs.First).Main_CPU = No_Main_CPU + then + Error_Msg ("No_Tasks_Unassigned_To_CPU restriction requires CPU" & + " aspect to be specified for main procedure"); + end if; + Check_Duplicated_Subunits; Check_Versions; Check_Consistency; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 367837f..2cfda7c 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -219,7 +219,6 @@ package body Impunit is ("a-tifiio", F), -- Ada.Text_IO.Fixed_IO ("a-tiflio", F), -- Ada.Text_IO.Float_IO ("a-tiinio", F), -- Ada.Text_IO.Integer_IO - ("a-tiinio", F), -- Ada.Text_IO.Integer_IO ("a-timoio", F), -- Ada.Text_IO.Modular_IO ("a-wtdeio", F), -- Ada.Wide_Text_IO.Decimal_IO ("a-wtenio", F), -- Ada.Wide_Text_IO.Enumeration_IO diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 53ca685..7293cf2 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -2793,9 +2793,9 @@ package body Inline is else Decl := Unit_Declaration_Node (Scop); - if Nkind_In (Decl, N_Subprogram_Declaration, - N_Task_Type_Declaration, - N_Subprogram_Body_Stub) + if Nkind (Decl) in N_Subprogram_Declaration + | N_Task_Type_Declaration + | N_Subprogram_Body_Stub then Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); end if; @@ -2968,9 +2968,8 @@ package body Inline is and then not GNATprove_Mode) or else - (Nkind_In (A, N_Real_Literal, - N_Integer_Literal, - N_Character_Literal) + (Nkind (A) in + N_Real_Literal | N_Integer_Literal | N_Character_Literal and then not Address_Taken (F)) then if Etype (F) /= Etype (A) then @@ -3378,10 +3377,10 @@ package body Inline is -- and string literals, and attributes that yield a universal -- type, because those must be resolved to a specific type. - if Nkind_In (Expression (N), N_Aggregate, - N_Character_Literal, - N_Null, - N_String_Literal) + if Nkind (Expression (N)) in N_Aggregate + | N_Character_Literal + | N_Null + | N_String_Literal or else Yields_Universal_Type (Expression (N)) then Ret := @@ -4234,7 +4233,7 @@ package body Inline is then Conv := Current_Entity (Id); - elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) + elsif Nkind (Id) in N_Selected_Component | N_Expanded_Name and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion then Conv := Current_Entity (Selector_Name (Id)); @@ -4366,13 +4365,13 @@ package body Inline is S := First (Stats); while Present (S) loop - if Nkind_In (S, N_Abort_Statement, - N_Asynchronous_Select, - N_Conditional_Entry_Call, - N_Delay_Relative_Statement, - N_Delay_Until_Statement, - N_Selective_Accept, - N_Timed_Entry_Call) + if Nkind (S) in N_Abort_Statement + | N_Asynchronous_Select + | N_Conditional_Entry_Call + | N_Delay_Relative_Statement + | N_Delay_Until_Statement + | N_Selective_Accept + | N_Timed_Entry_Call then Cannot_Inline ("cannot inline & (non-allowed statement)?", S, Subp); @@ -4632,13 +4631,11 @@ package body Inline is Backend_Not_Inlined_Subps := No_Elist; end Initialize; - -------------------------------------------- - -- Inline_Static_Expression_Function_Call -- - -------------------------------------------- + --------------------------------- + -- Inline_Static_Function_Call -- + --------------------------------- - procedure Inline_Static_Expression_Function_Call - (N : Node_Id; Subp : Entity_Id) - is + procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id) is function Replace_Formal (N : Node_Id) return Traverse_Result; -- Replace each occurrence of a formal with the corresponding actual, @@ -4697,10 +4694,10 @@ package body Inline is procedure Reset_Slocs is new Traverse_Proc (Reset_Sloc); - -- Start of processing for Inline_Static_Expression_Function_Call + -- Start of processing for Inline_Static_Function_Call begin - pragma Assert (Is_Static_Expression_Function_Call (N)); + pragma Assert (Is_Static_Function_Call (N)); declare Decls : constant List_Id := New_List; @@ -4759,7 +4756,7 @@ package body Inline is Reset_Actual_Mapping_For_Inlined_Call (Subp); end; - end Inline_Static_Expression_Function_Call; + end Inline_Static_Function_Call; ------------------------ -- Instantiate_Bodies -- @@ -5114,18 +5111,18 @@ package body Inline is end if; if Present (Item_Id) - and then Nam_In (Chars (Item_Id), Name_Contract_Cases, - Name_Global, - Name_Depends, - Name_Postcondition, - Name_Precondition, - Name_Refined_Global, - Name_Refined_Depends, - Name_Refined_Post, - Name_Test_Case, - Name_Unmodified, - Name_Unreferenced, - Name_Unused) + and then Chars (Item_Id) in Name_Contract_Cases + | Name_Global + | Name_Depends + | Name_Postcondition + | Name_Precondition + | Name_Refined_Global + | Name_Refined_Depends + | Name_Refined_Post + | Name_Test_Case + | Name_Unmodified + | Name_Unreferenced + | Name_Unused then Remove (Item); end if; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index a7f4aab..51eab9c 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -227,11 +227,11 @@ package Inline is -- Check a list of statements, Stats, that make inlining of Subp not -- worthwhile, including any tasking statement, nested at any level. - procedure Inline_Static_Expression_Function_Call + procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id); - -- Evaluate static call to a static expression function Subp, substituting - -- actuals in place of references to their corresponding formals and - -- rewriting the call N as a fully folded and static result expression. + -- Evaluate static call to a static function Subp, substituting actuals in + -- place of references to their corresponding formals and rewriting the + -- call N as a fully folded and static result expression. procedure List_Inlining_Info; -- Generate listing of calls inlined by the frontend plus listing of diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 57c434b..6fbcdce 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -562,7 +562,7 @@ package body Lib.Writ is Write_Info_Str (" O"); Write_Info_Char (OA_Setting (Unit_Num)); - if Ekind_In (Uent, E_Package, E_Package_Body) + if Ekind (Uent) in E_Package | E_Package_Body and then Present (Finalizer (Uent)) then Write_Info_Str (" PF"); @@ -1220,8 +1220,8 @@ package body Lib.Writ is if Nkind (U) = N_Subprogram_Body and then Present (Corresponding_Spec (U)) and then - Ekind_In (Corresponding_Spec (U), E_Generic_Procedure, - E_Generic_Function) + Ekind (Corresponding_Spec (U)) in E_Generic_Procedure + | E_Generic_Function then null; diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index ea5f88f..269d8ee 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -181,11 +181,11 @@ package body SPARK_Specific is -- If N is the defining identifier for a subprogram, then return the -- enclosing subprogram or package, not this subprogram. - if Nkind_In (N, N_Defining_Identifier, N_Defining_Operator_Symbol) - and then (Ekind (N) in Entry_Kind - or else Ekind (N) = E_Subprogram_Body - or else Ekind (N) in Generic_Subprogram_Kind - or else Ekind (N) in Subprogram_Kind) + if Nkind (N) in N_Defining_Identifier | N_Defining_Operator_Symbol + and then Ekind (N) in Entry_Kind + | E_Subprogram_Body + | Generic_Subprogram_Kind + | Subprogram_Kind then Context := Parent (Unit_Declaration_Node (N)); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 2c313ea..ae4b4c7 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -569,10 +569,9 @@ package body Lib.Xref is P := Parent (P); if Nkind (P) = N_Pragma then - if Nam_In (Pragma_Name_Unmapped (P), - Name_Warnings, - Name_Unmodified, - Name_Unreferenced) + if Pragma_Name_Unmapped (P) in Name_Warnings + | Name_Unmodified + | Name_Unreferenced then return False; end if; @@ -596,7 +595,12 @@ package body Lib.Xref is -- Start of processing for Generate_Reference begin - pragma Assert (Nkind (E) in N_Entity); + -- May happen in case of severe errors + + if Nkind (E) not in N_Entity then + return; + end if; + Find_Actual (N, Formal, Call); if Present (Formal) then @@ -911,7 +915,7 @@ package body Lib.Xref is -- since the attribute acts as an anonymous alias of the function -- result and not as a real reference to the function. - elsif Ekind_In (E, E_Function, E_Generic_Function) + elsif Ekind (E) in E_Function | E_Generic_Function and then Is_Entity_Name (N) and then Is_Attribute_Result (Parent (N)) then @@ -1006,18 +1010,18 @@ package body Lib.Xref is and then Typ /= ' ' then - if Nkind_In (N, N_Identifier, - N_Defining_Identifier, - N_Defining_Operator_Symbol, - N_Operator_Symbol, - N_Defining_Character_Literal) - or else Nkind (N) in N_Op + if Nkind (N) in N_Identifier + | N_Defining_Identifier + | N_Defining_Operator_Symbol + | N_Operator_Symbol + | N_Defining_Character_Literal + | N_Op or else (Nkind (N) = N_Character_Literal and then Sloc (Entity (N)) /= Standard_Location) then Nod := N; - elsif Nkind_In (N, N_Expanded_Name, N_Selected_Component) then + elsif Nkind (N) in N_Expanded_Name | N_Selected_Component then Nod := Selector_Name (N); else @@ -1135,7 +1139,7 @@ package body Lib.Xref is -- reads/writes of private protected components) and not worth the -- effort. - if Ekind_In (Ent, E_Abstract_State, E_Constant, E_Variable) + if Ekind (Ent) in E_Abstract_State | E_Constant | E_Variable and then Present (Encapsulating_State (Ent)) and then Is_Single_Concurrent_Object (Encapsulating_State (Ent)) then @@ -2314,15 +2318,15 @@ package body Lib.Xref is -- Special handling for access parameters and objects and -- components of an anonymous access type. - if Ekind_In (Etype (XE.Key.Ent), - E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type) + if Ekind (Etype (XE.Key.Ent)) in + E_Anonymous_Access_Type + | E_Anonymous_Access_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type then if Is_Formal (XE.Key.Ent) or else - Ekind_In - (XE.Key.Ent, E_Variable, E_Constant, E_Component) + Ekind (XE.Key.Ent) in + E_Variable | E_Constant | E_Component then Ctyp := 'p'; end if; diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index 03f5a7b..fb11e02 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -243,9 +243,9 @@ package body System.Task_Primitives.Operations is return Ceiling_Support; end Get_Ceiling_Support; - pragma Warnings (Off, "non-static call not allowed in preelaborated unit"); + pragma Warnings (Off, "non-preelaborable call not allowed*"); Ceiling_Support : constant Boolean := Get_Ceiling_Support; - pragma Warnings (On, "non-static call not allowed in preelaborated unit"); + pragma Warnings (On, "non-preelaborable call not allowed*"); -- True if the locking policy is Ceiling_Locking, and the current process -- has permission to use this policy. The process has permission if it is -- running as 'root', or if the capability was set by the setcap command, diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb index 1b3a88c..0f0c872 100644 --- a/gcc/ada/libgnat/a-cbdlli.adb +++ b/gcc/ada/libgnat/a-cbdlli.adb @@ -29,7 +29,9 @@ with System; use type System.Address; -package body Ada.Containers.Bounded_Doubly_Linked_Lists is +package body Ada.Containers.Bounded_Doubly_Linked_Lists with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads index 0103a03..74639cf 100644 --- a/gcc/ada/libgnat/a-cbdlli.ads +++ b/gcc/ada/libgnat/a-cbdlli.ads @@ -43,7 +43,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Bounded_Doubly_Linked_Lists is +package Ada.Containers.Bounded_Doubly_Linked_Lists with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb index b76bd62..1881db2 100644 --- a/gcc/ada/libgnat/a-cbhama.adb +++ b/gcc/ada/libgnat/a-cbhama.adb @@ -39,7 +39,9 @@ with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; -package body Ada.Containers.Bounded_Hashed_Maps is +package body Ada.Containers.Bounded_Hashed_Maps with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads index cf76fbb..86fed4e 100644 --- a/gcc/ada/libgnat/a-cbhama.ads +++ b/gcc/ada/libgnat/a-cbhama.ads @@ -45,7 +45,9 @@ generic with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Bounded_Hashed_Maps is +package Ada.Containers.Bounded_Hashed_Maps with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb index 8a786f1..a332bd7 100644 --- a/gcc/ada/libgnat/a-cbhase.adb +++ b/gcc/ada/libgnat/a-cbhase.adb @@ -39,7 +39,9 @@ with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; -package body Ada.Containers.Bounded_Hashed_Sets is +package body Ada.Containers.Bounded_Hashed_Sets with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads index 663dcb3..01903c7 100644 --- a/gcc/ada/libgnat/a-cbhase.ads +++ b/gcc/ada/libgnat/a-cbhase.ads @@ -48,7 +48,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Bounded_Hashed_Sets is +package Ada.Containers.Bounded_Hashed_Sets with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cbmutr.adb b/gcc/ada/libgnat/a-cbmutr.adb index f9048b0..58db8cf 100644 --- a/gcc/ada/libgnat/a-cbmutr.adb +++ b/gcc/ada/libgnat/a-cbmutr.adb @@ -30,7 +30,9 @@ with Ada.Finalization; with System; use type System.Address; -package body Ada.Containers.Bounded_Multiway_Trees is +package body Ada.Containers.Bounded_Multiway_Trees with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads index 8008e1d..653407b 100644 --- a/gcc/ada/libgnat/a-cbmutr.ads +++ b/gcc/ada/libgnat/a-cbmutr.ads @@ -41,7 +41,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Bounded_Multiway_Trees is +package Ada.Containers.Bounded_Multiway_Trees with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cborma.adb b/gcc/ada/libgnat/a-cborma.adb index 1e384d7..6f59471 100644 --- a/gcc/ada/libgnat/a-cborma.adb +++ b/gcc/ada/libgnat/a-cborma.adb @@ -39,7 +39,9 @@ pragma Elaborate_All with System; use type System.Address; -package body Ada.Containers.Bounded_Ordered_Maps is +package body Ada.Containers.Bounded_Ordered_Maps with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads index 1cfc412..c199a09 100644 --- a/gcc/ada/libgnat/a-cborma.ads +++ b/gcc/ada/libgnat/a-cborma.ads @@ -44,7 +44,9 @@ generic with function "<" (Left, Right : Key_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Bounded_Ordered_Maps is +package Ada.Containers.Bounded_Ordered_Maps with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb index af5efc1..af4f87f 100644 --- a/gcc/ada/libgnat/a-cborse.adb +++ b/gcc/ada/libgnat/a-cborse.adb @@ -42,7 +42,9 @@ pragma Elaborate_All with System; use type System.Address; -package body Ada.Containers.Bounded_Ordered_Sets is +package body Ada.Containers.Bounded_Ordered_Sets with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads index a119c82..52b8786 100644 --- a/gcc/ada/libgnat/a-cborse.ads +++ b/gcc/ada/libgnat/a-cborse.ads @@ -44,7 +44,9 @@ generic with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Bounded_Ordered_Sets is +package Ada.Containers.Bounded_Ordered_Sets with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cbprqu.adb b/gcc/ada/libgnat/a-cbprqu.adb index 27b5bd3..2e97291 100644 --- a/gcc/ada/libgnat/a-cbprqu.adb +++ b/gcc/ada/libgnat/a-cbprqu.adb @@ -27,7 +27,9 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -package body Ada.Containers.Bounded_Priority_Queues is +package body Ada.Containers.Bounded_Priority_Queues with + SPARK_Mode => Off +is package body Implementation is diff --git a/gcc/ada/libgnat/a-cbprqu.ads b/gcc/ada/libgnat/a-cbprqu.ads index e5a9b66..6259a47 100644 --- a/gcc/ada/libgnat/a-cbprqu.ads +++ b/gcc/ada/libgnat/a-cbprqu.ads @@ -51,7 +51,9 @@ generic Default_Capacity : Count_Type; Default_Ceiling : System.Any_Priority := System.Priority'Last; -package Ada.Containers.Bounded_Priority_Queues is +package Ada.Containers.Bounded_Priority_Queues with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; diff --git a/gcc/ada/libgnat/a-cbsyqu.adb b/gcc/ada/libgnat/a-cbsyqu.adb index 62cad5d..abb0e79 100644 --- a/gcc/ada/libgnat/a-cbsyqu.adb +++ b/gcc/ada/libgnat/a-cbsyqu.adb @@ -27,7 +27,9 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -package body Ada.Containers.Bounded_Synchronized_Queues is +package body Ada.Containers.Bounded_Synchronized_Queues with + SPARK_Mode => Off +is package body Implementation is diff --git a/gcc/ada/libgnat/a-cbsyqu.ads b/gcc/ada/libgnat/a-cbsyqu.ads index 07fe84b..61504fa 100644 --- a/gcc/ada/libgnat/a-cbsyqu.ads +++ b/gcc/ada/libgnat/a-cbsyqu.ads @@ -41,7 +41,9 @@ generic Default_Capacity : Count_Type; Default_Ceiling : System.Any_Priority := System.Priority'Last; -package Ada.Containers.Bounded_Synchronized_Queues is +package Ada.Containers.Bounded_Synchronized_Queues with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb index 73c7980..a668db1 100644 --- a/gcc/ada/libgnat/a-cdlili.adb +++ b/gcc/ada/libgnat/a-cdlili.adb @@ -31,7 +31,9 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; -package body Ada.Containers.Doubly_Linked_Lists is +package body Ada.Containers.Doubly_Linked_Lists with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cdlili.ads b/gcc/ada/libgnat/a-cdlili.ads index 424a346..89216e0 100644 --- a/gcc/ada/libgnat/a-cdlili.ads +++ b/gcc/ada/libgnat/a-cdlili.ads @@ -43,7 +43,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Doubly_Linked_Lists is +package Ada.Containers.Doubly_Linked_Lists with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-chahan.adb b/gcc/ada/libgnat/a-chahan.adb index faee41b..de66846 100644 --- a/gcc/ada/libgnat/a-chahan.adb +++ b/gcc/ada/libgnat/a-chahan.adb @@ -399,6 +399,17 @@ package body Ada.Characters.Handling is return False; end Is_Mark; + ------------- + -- Is_NFKC -- + ------------- + + function Is_NFKC (Item : Character) return Boolean is + begin + return Character'Pos (Item) not in + 160 | 168 | 170 | 175 | 178 | 179 | 180 | 181 | 184 | 185 | 186 | + 188 | 189 | 190; + end Is_NFKC; + --------------------- -- Is_Other_Format -- --------------------- diff --git a/gcc/ada/libgnat/a-chahan.ads b/gcc/ada/libgnat/a-chahan.ads index 957d623..04f975c 100644 --- a/gcc/ada/libgnat/a-chahan.ads +++ b/gcc/ada/libgnat/a-chahan.ads @@ -58,6 +58,7 @@ package Ada.Characters.Handling is function Is_Other_Format (Item : Character) return Boolean; function Is_Punctuation_Connector (Item : Character) return Boolean; function Is_Space (Item : Character) return Boolean; + function Is_NFKC (Item : Character) return Boolean; --------------------------------------------------- -- Conversion Functions for Character and String -- diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb index a086935..0898db8 100644 --- a/gcc/ada/libgnat/a-cidlli.adb +++ b/gcc/ada/libgnat/a-cidlli.adb @@ -31,7 +31,9 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; -package body Ada.Containers.Indefinite_Doubly_Linked_Lists is +package body Ada.Containers.Indefinite_Doubly_Linked_Lists with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cidlli.ads b/gcc/ada/libgnat/a-cidlli.ads index 1111bbb..e9220a6 100644 --- a/gcc/ada/libgnat/a-cidlli.ads +++ b/gcc/ada/libgnat/a-cidlli.ads @@ -43,7 +43,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Indefinite_Doubly_Linked_Lists is +package Ada.Containers.Indefinite_Doubly_Linked_Lists with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb index 7c4d427..9f5aed7 100644 --- a/gcc/ada/libgnat/a-cihama.adb +++ b/gcc/ada/libgnat/a-cihama.adb @@ -39,7 +39,9 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; -package body Ada.Containers.Indefinite_Hashed_Maps is +package body Ada.Containers.Indefinite_Hashed_Maps with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads index 4d9233a..fb6f4e0 100644 --- a/gcc/ada/libgnat/a-cihama.ads +++ b/gcc/ada/libgnat/a-cihama.ads @@ -45,7 +45,9 @@ generic with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Indefinite_Hashed_Maps is +package Ada.Containers.Indefinite_Hashed_Maps with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb index 3d5af6a..b91532d 100644 --- a/gcc/ada/libgnat/a-cihase.adb +++ b/gcc/ada/libgnat/a-cihase.adb @@ -41,7 +41,9 @@ with Ada.Containers.Prime_Numbers; with System; use type System.Address; -package body Ada.Containers.Indefinite_Hashed_Sets is +package body Ada.Containers.Indefinite_Hashed_Sets with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cihase.ads b/gcc/ada/libgnat/a-cihase.ads index e6dcef6..926e07f 100644 --- a/gcc/ada/libgnat/a-cihase.ads +++ b/gcc/ada/libgnat/a-cihase.ads @@ -48,7 +48,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Indefinite_Hashed_Sets is +package Ada.Containers.Indefinite_Hashed_Sets with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cimutr.adb b/gcc/ada/libgnat/a-cimutr.adb index ac7e534..293275a 100644 --- a/gcc/ada/libgnat/a-cimutr.adb +++ b/gcc/ada/libgnat/a-cimutr.adb @@ -31,7 +31,9 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; -package body Ada.Containers.Indefinite_Multiway_Trees is +package body Ada.Containers.Indefinite_Multiway_Trees with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cimutr.ads b/gcc/ada/libgnat/a-cimutr.ads index 5d21325..474a1b5 100644 --- a/gcc/ada/libgnat/a-cimutr.ads +++ b/gcc/ada/libgnat/a-cimutr.ads @@ -42,7 +42,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Indefinite_Multiway_Trees is +package Ada.Containers.Indefinite_Multiway_Trees with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-ciorma.adb b/gcc/ada/libgnat/a-ciorma.adb index 25cf674..86cd01f 100644 --- a/gcc/ada/libgnat/a-ciorma.adb +++ b/gcc/ada/libgnat/a-ciorma.adb @@ -39,7 +39,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with System; use type System.Address; -package body Ada.Containers.Indefinite_Ordered_Maps is +package body Ada.Containers.Indefinite_Ordered_Maps with + SPARK_Mode => Off +is pragma Suppress (All_Checks); pragma Warnings (Off, "variable ""Busy*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-ciorma.ads b/gcc/ada/libgnat/a-ciorma.ads index bc4581d..a7799a6 100644 --- a/gcc/ada/libgnat/a-ciorma.ads +++ b/gcc/ada/libgnat/a-ciorma.ads @@ -44,7 +44,9 @@ generic with function "<" (Left, Right : Key_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Indefinite_Ordered_Maps is +package Ada.Containers.Indefinite_Ordered_Maps with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-ciormu.adb b/gcc/ada/libgnat/a-ciormu.adb index 6299338..110d734 100644 --- a/gcc/ada/libgnat/a-ciormu.adb +++ b/gcc/ada/libgnat/a-ciormu.adb @@ -40,7 +40,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with System; use type System.Address; -package body Ada.Containers.Indefinite_Ordered_Multisets is +package body Ada.Containers.Indefinite_Ordered_Multisets with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-ciormu.ads b/gcc/ada/libgnat/a-ciormu.ads index ad4e1b2..474ccc7 100644 --- a/gcc/ada/libgnat/a-ciormu.ads +++ b/gcc/ada/libgnat/a-ciormu.ads @@ -43,7 +43,9 @@ generic with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Indefinite_Ordered_Multisets is +package Ada.Containers.Indefinite_Ordered_Multisets with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb index f9647a2..772061d 100644 --- a/gcc/ada/libgnat/a-ciorse.adb +++ b/gcc/ada/libgnat/a-ciorse.adb @@ -42,7 +42,9 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; -package body Ada.Containers.Indefinite_Ordered_Sets is +package body Ada.Containers.Indefinite_Ordered_Sets with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads index 26cda02..1eb8135 100644 --- a/gcc/ada/libgnat/a-ciorse.ads +++ b/gcc/ada/libgnat/a-ciorse.ads @@ -44,7 +44,9 @@ generic with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Indefinite_Ordered_Sets is +package Ada.Containers.Indefinite_Ordered_Sets with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb index f542462..7f2d8e1 100644 --- a/gcc/ada/libgnat/a-cohama.adb +++ b/gcc/ada/libgnat/a-cohama.adb @@ -39,7 +39,9 @@ with Ada.Containers.Helpers; use Ada.Containers.Helpers; with System; use type System.Address; -package body Ada.Containers.Hashed_Maps is +package body Ada.Containers.Hashed_Maps with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads index 3cc9239..9d927bd 100644 --- a/gcc/ada/libgnat/a-cohama.ads +++ b/gcc/ada/libgnat/a-cohama.ads @@ -88,7 +88,9 @@ generic -- map values returns an unspecified value. The exact arguments and number -- of calls of this generic formal function by the function "=" on map -- values are unspecified. -package Ada.Containers.Hashed_Maps is +package Ada.Containers.Hashed_Maps with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb index 45a1b2e..bc4e53f 100644 --- a/gcc/ada/libgnat/a-cohase.adb +++ b/gcc/ada/libgnat/a-cohase.adb @@ -41,7 +41,9 @@ with Ada.Containers.Prime_Numbers; with System; use type System.Address; -package body Ada.Containers.Hashed_Sets is +package body Ada.Containers.Hashed_Sets with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads index 523e554..3645ed0 100644 --- a/gcc/ada/libgnat/a-cohase.ads +++ b/gcc/ada/libgnat/a-cohase.ads @@ -48,7 +48,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Hashed_Sets is +package Ada.Containers.Hashed_Sets with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb index 85c30fa..79e36ae 100644 --- a/gcc/ada/libgnat/a-coinve.adb +++ b/gcc/ada/libgnat/a-coinve.adb @@ -32,7 +32,9 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; -package body Ada.Containers.Indefinite_Vectors is +package body Ada.Containers.Indefinite_Vectors with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-coinve.ads b/gcc/ada/libgnat/a-coinve.ads index 2d54438..075a184 100644 --- a/gcc/ada/libgnat/a-coinve.ads +++ b/gcc/ada/libgnat/a-coinve.ads @@ -43,7 +43,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Indefinite_Vectors is +package Ada.Containers.Indefinite_Vectors with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-comutr.adb b/gcc/ada/libgnat/a-comutr.adb index 6468839..76ff751 100644 --- a/gcc/ada/libgnat/a-comutr.adb +++ b/gcc/ada/libgnat/a-comutr.adb @@ -32,7 +32,9 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; -package body Ada.Containers.Multiway_Trees is +package body Ada.Containers.Multiway_Trees with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-comutr.ads b/gcc/ada/libgnat/a-comutr.ads index 89e5797..46934a1 100644 --- a/gcc/ada/libgnat/a-comutr.ads +++ b/gcc/ada/libgnat/a-comutr.ads @@ -42,7 +42,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Multiway_Trees is +package Ada.Containers.Multiway_Trees with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb index 197271b..c2a0a83 100644 --- a/gcc/ada/libgnat/a-convec.adb +++ b/gcc/ada/libgnat/a-convec.adb @@ -31,8 +31,11 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; -package body Ada.Containers.Vectors is +package body Ada.Containers.Vectors with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); @@ -2297,6 +2300,31 @@ package body Ada.Containers.Vectors is end return; end Pseudo_Reference; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ------------------- -- Query_Element -- ------------------- diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads index 8ad31a2..a12e456 100644 --- a/gcc/ada/libgnat/a-convec.ads +++ b/gcc/ada/libgnat/a-convec.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; -- The language-defined generic package Containers.Vectors provides private -- types Vector and Cursor, and a set of operations for each type. A vector @@ -70,7 +71,9 @@ generic -- number of calls of this generic formal function by the functions defined -- to use it are unspecified. -package Ada.Containers.Vectors is +package Ada.Containers.Vectors with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -694,7 +697,10 @@ private Elements : Elements_Access := null; Last : Extended_Index := No_Index; TC : aliased Tamper_Counts; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector); overriding procedure Adjust (Container : in out Vector); overriding procedure Finalize (Container : in out Vector); diff --git a/gcc/ada/libgnat/a-coorma.adb b/gcc/ada/libgnat/a-coorma.adb index 9bad901..4106d58 100644 --- a/gcc/ada/libgnat/a-coorma.adb +++ b/gcc/ada/libgnat/a-coorma.adb @@ -39,7 +39,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with System; use type System.Address; -package body Ada.Containers.Ordered_Maps is +package body Ada.Containers.Ordered_Maps with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-coorma.ads b/gcc/ada/libgnat/a-coorma.ads index 02d97e4..e2d5e1e 100644 --- a/gcc/ada/libgnat/a-coorma.ads +++ b/gcc/ada/libgnat/a-coorma.ads @@ -44,7 +44,9 @@ generic with function "<" (Left, Right : Key_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Ordered_Maps is +package Ada.Containers.Ordered_Maps with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-coormu.adb b/gcc/ada/libgnat/a-coormu.adb index 66cc77e..c02a9f1 100644 --- a/gcc/ada/libgnat/a-coormu.adb +++ b/gcc/ada/libgnat/a-coormu.adb @@ -40,7 +40,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with System; use type System.Address; -package body Ada.Containers.Ordered_Multisets is +package body Ada.Containers.Ordered_Multisets with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-coormu.ads b/gcc/ada/libgnat/a-coormu.ads index cdaee85..9c6c3ae 100644 --- a/gcc/ada/libgnat/a-coormu.ads +++ b/gcc/ada/libgnat/a-coormu.ads @@ -42,7 +42,9 @@ generic with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Ordered_Multisets is +package Ada.Containers.Ordered_Multisets with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb index 8c37d11..15b59dd 100644 --- a/gcc/ada/libgnat/a-coorse.adb +++ b/gcc/ada/libgnat/a-coorse.adb @@ -42,7 +42,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with System; use type System.Address; -package body Ada.Containers.Ordered_Sets is +package body Ada.Containers.Ordered_Sets with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads index 3699e70..42e5b49 100644 --- a/gcc/ada/libgnat/a-coorse.ads +++ b/gcc/ada/libgnat/a-coorse.ads @@ -44,7 +44,9 @@ generic with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Ordered_Sets is +package Ada.Containers.Ordered_Sets with + SPARK_Mode => Off +is pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; diff --git a/gcc/ada/libgnat/a-nbnbin.adb b/gcc/ada/libgnat/a-nbnbin.adb index d3c5f6a..b919d86 100644 --- a/gcc/ada/libgnat/a-nbnbin.adb +++ b/gcc/ada/libgnat/a-nbnbin.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Ada.Unchecked_Deallocation; with Ada.Strings.Text_Output.Utils; diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads index 5cf7960..7b4974a 100644 --- a/gcc/ada/libgnat/a-nbnbin.ads +++ b/gcc/ada/libgnat/a-nbnbin.ads @@ -13,8 +13,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Ada.Strings.Text_Output; use Ada.Strings.Text_Output; private with Ada.Finalization; diff --git a/gcc/ada/libgnat/a-nbnbin__gmp.adb b/gcc/ada/libgnat/a-nbnbin__gmp.adb index 9481eed..2e8a260 100644 --- a/gcc/ada/libgnat/a-nbnbin__gmp.adb +++ b/gcc/ada/libgnat/a-nbnbin__gmp.adb @@ -31,8 +31,6 @@ -- This is the GMP version of this package -pragma Ada_2020; - with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Interfaces.C; use Interfaces.C; diff --git a/gcc/ada/libgnat/a-nbnbre.adb b/gcc/ada/libgnat/a-nbnbre.adb index 987cdb4..d61668d 100644 --- a/gcc/ada/libgnat/a-nbnbre.adb +++ b/gcc/ada/libgnat/a-nbnbre.adb @@ -31,8 +31,6 @@ -- This is the default version of this package, based on Big_Integers only. -pragma Ada_2020; - with Ada.Strings.Text_Output.Utils; package body Ada.Numerics.Big_Numbers.Big_Reals is diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads index 2d4ff63..5a8ebb9 100644 --- a/gcc/ada/libgnat/a-nbnbre.ads +++ b/gcc/ada/libgnat/a-nbnbre.ads @@ -13,8 +13,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Ada.Numerics.Big_Numbers.Big_Integers; with Ada.Strings.Text_Output; use Ada.Strings.Text_Output; diff --git a/gcc/ada/libgnat/a-numaux.ads b/gcc/ada/libgnat/a-numaux.ads index 3ad7067..4154e1a 100644 --- a/gcc/ada/libgnat/a-numaux.ads +++ b/gcc/ada/libgnat/a-numaux.ads @@ -58,55 +58,55 @@ package Ada.Numerics.Aux is -- all as pure functions, because indeed all of them are in fact pure. function Sin (X : Double) return Double; - pragma Import (C, Sin, "sin"); + pragma Import (Intrinsic, Sin, "sin"); pragma Pure_Function (Sin); function Cos (X : Double) return Double; - pragma Import (C, Cos, "cos"); + pragma Import (Intrinsic, Cos, "cos"); pragma Pure_Function (Cos); function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); + pragma Import (Intrinsic, Tan, "tan"); pragma Pure_Function (Tan); function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); + pragma Import (Intrinsic, Exp, "exp"); pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); + pragma Import (Intrinsic, Sqrt, "sqrt"); pragma Pure_Function (Sqrt); function Log (X : Double) return Double; - pragma Import (C, Log, "log"); + pragma Import (Intrinsic, Log, "log"); pragma Pure_Function (Log); function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); + pragma Import (Intrinsic, Acos, "acos"); pragma Pure_Function (Acos); function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); + pragma Import (Intrinsic, Asin, "asin"); pragma Pure_Function (Asin); function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); + pragma Import (Intrinsic, Atan, "atan"); pragma Pure_Function (Atan); function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); + pragma Import (Intrinsic, Sinh, "sinh"); pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); + pragma Import (Intrinsic, Cosh, "cosh"); pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); + pragma Import (Intrinsic, Tanh, "tanh"); pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); + pragma Import (Intrinsic, Pow, "pow"); pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__darwin.ads b/gcc/ada/libgnat/a-numaux__darwin.ads index f2a4428..add87a4 100644 --- a/gcc/ada/libgnat/a-numaux__darwin.ads +++ b/gcc/ada/libgnat/a-numaux__darwin.ads @@ -57,47 +57,47 @@ package Ada.Numerics.Aux is -- all as pure functions, because indeed all of them are in fact pure. function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); + pragma Import (Intrinsic, Tan, "tan"); pragma Pure_Function (Tan); function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); + pragma Import (Intrinsic, Exp, "exp"); pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); + pragma Import (Intrinsic, Sqrt, "sqrt"); pragma Pure_Function (Sqrt); function Log (X : Double) return Double; - pragma Import (C, Log, "log"); + pragma Import (Intrinsic, Log, "log"); pragma Pure_Function (Log); function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); + pragma Import (Intrinsic, Acos, "acos"); pragma Pure_Function (Acos); function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); + pragma Import (Intrinsic, Asin, "asin"); pragma Pure_Function (Asin); function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); + pragma Import (Intrinsic, Atan, "atan"); pragma Pure_Function (Atan); function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); + pragma Import (Intrinsic, Sinh, "sinh"); pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); + pragma Import (Intrinsic, Cosh, "cosh"); pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); + pragma Import (Intrinsic, Tanh, "tanh"); pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); + pragma Import (Intrinsic, Pow, "pow"); pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__x86.ads b/gcc/ada/libgnat/a-numaux__dummy.adb index 8324822..f5d72ec 100644 --- a/gcc/ada/libgnat/a-numaux__x86.ads +++ b/gcc/ada/libgnat/a-numaux__dummy.adb @@ -4,8 +4,7 @@ -- -- -- A D A . N U M E R I C S . A U X -- -- -- --- S p e c -- --- (Machine Version for x86) -- +-- B o d y -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- @@ -30,47 +29,4 @@ -- -- ------------------------------------------------------------------------------ --- This version is for the x86 using the 80-bit x86 long double format with --- inline asm statements. - -package Ada.Numerics.Aux is - pragma Pure; - - type Double is new Long_Long_Float; - - function Sin (X : Double) return Double; - - function Cos (X : Double) return Double; - - function Tan (X : Double) return Double; - - function Exp (X : Double) return Double; - - function Sqrt (X : Double) return Double; - - function Log (X : Double) return Double; - - function Atan (X : Double) return Double; - - function Acos (X : Double) return Double; - - function Asin (X : Double) return Double; - - function Sinh (X : Double) return Double; - - function Cosh (X : Double) return Double; - - function Tanh (X : Double) return Double; - - function Pow (X, Y : Double) return Double; - -private - pragma Inline (Atan); - pragma Inline (Cos); - pragma Inline (Tan); - pragma Inline (Exp); - pragma Inline (Log); - pragma Inline (Sin); - pragma Inline (Sqrt); - -end Ada.Numerics.Aux; +pragma No_Body; diff --git a/gcc/ada/libgnat/a-numaux__libc-x86.ads b/gcc/ada/libgnat/a-numaux__libc-x86.ads index c4647fd..f6deebe 100644 --- a/gcc/ada/libgnat/a-numaux__libc-x86.ads +++ b/gcc/ada/libgnat/a-numaux__libc-x86.ads @@ -43,55 +43,55 @@ package Ada.Numerics.Aux is -- all as pure functions, because indeed all of them are in fact pure. function Sin (X : Double) return Double; - pragma Import (C, Sin, "sinl"); + pragma Import (Intrinsic, Sin, "sinl"); pragma Pure_Function (Sin); function Cos (X : Double) return Double; - pragma Import (C, Cos, "cosl"); + pragma Import (Intrinsic, Cos, "cosl"); pragma Pure_Function (Cos); function Tan (X : Double) return Double; - pragma Import (C, Tan, "tanl"); + pragma Import (Intrinsic, Tan, "tanl"); pragma Pure_Function (Tan); function Exp (X : Double) return Double; - pragma Import (C, Exp, "expl"); + pragma Import (Intrinsic, Exp, "expl"); pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrtl"); + pragma Import (Intrinsic, Sqrt, "sqrtl"); pragma Pure_Function (Sqrt); function Log (X : Double) return Double; - pragma Import (C, Log, "logl"); + pragma Import (Intrinsic, Log, "logl"); pragma Pure_Function (Log); function Acos (X : Double) return Double; - pragma Import (C, Acos, "acosl"); + pragma Import (Intrinsic, Acos, "acosl"); pragma Pure_Function (Acos); function Asin (X : Double) return Double; - pragma Import (C, Asin, "asinl"); + pragma Import (Intrinsic, Asin, "asinl"); pragma Pure_Function (Asin); function Atan (X : Double) return Double; - pragma Import (C, Atan, "atanl"); + pragma Import (Intrinsic, Atan, "atanl"); pragma Pure_Function (Atan); function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinhl"); + pragma Import (Intrinsic, Sinh, "sinhl"); pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "coshl"); + pragma Import (Intrinsic, Cosh, "coshl"); pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanhl"); + pragma Import (Intrinsic, Tanh, "tanhl"); pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "powl"); + pragma Import (Intrinsic, Pow, "powl"); pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__vxworks.ads b/gcc/ada/libgnat/a-numaux__vxworks.ads index c291334..410655d 100644 --- a/gcc/ada/libgnat/a-numaux__vxworks.ads +++ b/gcc/ada/libgnat/a-numaux__vxworks.ads @@ -43,55 +43,55 @@ package Ada.Numerics.Aux is -- all as pure functions, because indeed all of them are in fact pure. function Sin (X : Double) return Double; - pragma Import (C, Sin, "sin"); + pragma Import (Intrinsic, Sin, "sin"); pragma Pure_Function (Sin); function Cos (X : Double) return Double; - pragma Import (C, Cos, "cos"); + pragma Import (Intrinsic, Cos, "cos"); pragma Pure_Function (Cos); function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); + pragma Import (Intrinsic, Tan, "tan"); pragma Pure_Function (Tan); function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); + pragma Import (Intrinsic, Exp, "exp"); pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); + pragma Import (Intrinsic, Sqrt, "sqrt"); pragma Pure_Function (Sqrt); function Log (X : Double) return Double; - pragma Import (C, Log, "log"); + pragma Import (Intrinsic, Log, "log"); pragma Pure_Function (Log); function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); + pragma Import (Intrinsic, Acos, "acos"); pragma Pure_Function (Acos); function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); + pragma Import (Intrinsic, Asin, "asin"); pragma Pure_Function (Asin); function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); + pragma Import (Intrinsic, Atan, "atan"); pragma Pure_Function (Atan); function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); + pragma Import (Intrinsic, Sinh, "sinh"); pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); + pragma Import (Intrinsic, Cosh, "cosh"); pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); + pragma Import (Intrinsic, Tanh, "tanh"); pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); + pragma Import (Intrinsic, Pow, "pow"); pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__x86.adb b/gcc/ada/libgnat/a-numaux__x86.adb deleted file mode 100644 index af22be2..0000000 --- a/gcc/ada/libgnat/a-numaux__x86.adb +++ /dev/null @@ -1,577 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- B o d y -- --- (Machine Version for x86) -- --- -- --- Copyright (C) 1998-2020, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Machine_Code; use System.Machine_Code; - -package body Ada.Numerics.Aux is - - NL : constant String := ASCII.LF & ASCII.HT; - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Is_Nan (X : Double) return Boolean; - -- Return True iff X is a IEEE NaN value - - function Logarithmic_Pow (X, Y : Double) return Double; - -- Implementation of X**Y using Exp and Log functions (binary base) - -- to calculate the exponentiation. This is used by Pow for values - -- for values of Y in the open interval (-0.25, 0.25) - - procedure Reduce (X : in out Double; Q : out Natural); - -- Implement reduction of X by Pi/2. Q is the quadrant of the final - -- result in the range 0..3. The absolute value of X is at most Pi/4. - -- It is needed to avoid a loss of accuracy for sin near Pi and cos - -- near Pi/2 due to the use of an insufficiently precise value of Pi - -- in the range reduction. - - pragma Inline (Is_Nan); - pragma Inline (Reduce); - - -------------------------------- - -- Basic Elementary Functions -- - -------------------------------- - - -- This section implements a few elementary functions that are used to - -- build the more complex ones. This ordering enables better inlining. - - ---------- - -- Atan -- - ---------- - - function Atan (X : Double) return Double is - Result : Double; - - begin - Asm (Template => - "fld1" & NL - & "fpatan", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - - -- The result value is NaN iff input was invalid - - if not (Result = Result) then - raise Argument_Error; - end if; - - return Result; - end Atan; - - --------- - -- Exp -- - --------- - - function Exp (X : Double) return Double is - Result : Double; - begin - Asm (Template => - "fldl2e " & NL - & "fmulp %%st, %%st(1)" & NL -- X * log2 (E) - & "fld %%st(0) " & NL - & "frndint " & NL -- Integer (X * Log2 (E)) - & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E)) - & "fxch " & NL - & "f2xm1 " & NL -- 2**(...) - 1 - & "fld1 " & NL - & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E))) - & "fscale " & NL -- E ** X - & "fstp %%st(1) ", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - return Result; - end Exp; - - ------------ - -- Is_Nan -- - ------------ - - function Is_Nan (X : Double) return Boolean is - begin - -- The IEEE NaN values are the only ones that do not equal themselves - - return X /= X; - end Is_Nan; - - --------- - -- Log -- - --------- - - function Log (X : Double) return Double is - Result : Double; - - begin - Asm (Template => - "fldln2 " & NL - & "fxch " & NL - & "fyl2x " & NL, - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - return Result; - end Log; - - ------------ - -- Reduce -- - ------------ - - procedure Reduce (X : in out Double; Q : out Natural) is - Half_Pi : constant := Pi / 2.0; - Two_Over_Pi : constant := 2.0 / Pi; - - HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); - M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant - P1 : constant Double := Double'Leading_Part (Half_Pi, HM); - P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); - P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); - P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); - P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 - - P4, HM); - P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); - K : Double; - R : Integer; - - begin - -- For X < 2.0**HM, all products below are computed exactly. - -- Due to cancellation effects all subtractions are exact as well. - -- As no double extended floating-point number has more than 75 - -- zeros after the binary point, the result will be the correctly - -- rounded result of X - K * (Pi / 2.0). - - K := X * Two_Over_Pi; - while abs K >= 2.0**HM loop - K := K * M - (K * M - K); - X := - (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - K := X * Two_Over_Pi; - end loop; - - -- If K is not a number (because X was not finite) raise exception - - if Is_Nan (K) then - raise Constraint_Error; - end if; - - -- Go through an integer temporary so as to use machine instructions - - R := Integer (Double'Rounding (K)); - Q := R mod 4; - K := Double (R); - X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - end Reduce; - - ---------- - -- Sqrt -- - ---------- - - function Sqrt (X : Double) return Double is - Result : Double; - - begin - if X < 0.0 then - raise Argument_Error; - end if; - - Asm (Template => "fsqrt", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - - return Result; - end Sqrt; - - -------------------------------- - -- Other Elementary Functions -- - -------------------------------- - - -- These are built using the previously implemented basic functions - - ---------- - -- Acos -- - ---------- - - function Acos (X : Double) return Double is - Result : Double; - - begin - Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X))); - - -- The result value is NaN iff input was invalid - - if Is_Nan (Result) then - raise Argument_Error; - end if; - - return Result; - end Acos; - - ---------- - -- Asin -- - ---------- - - function Asin (X : Double) return Double is - Result : Double; - - begin - Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X))); - - -- The result value is NaN iff input was invalid - - if Is_Nan (Result) then - raise Argument_Error; - end if; - - return Result; - end Asin; - - --------- - -- Cos -- - --------- - - function Cos (X : Double) return Double is - Reduced_X : Double := abs X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if Reduced_X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 1 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", -Reduced_X)); - - when 2 => - Asm (Template => "fcos ; fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 3 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end case; - - else - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Cos; - - --------------------- - -- Logarithmic_Pow -- - --------------------- - - function Logarithmic_Pow (X, Y : Double) return Double is - Result : Double; - begin - Asm (Template => "" -- X : Y - & "fyl2x " & NL -- Y * Log2 (X) - & "fld %%st(0) " & NL -- Y * Log2 (X) : Y * Log2 (X) - & "frndint " & NL -- Int (...) : Y * Log2 (X) - & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...) - & "fxch " & NL -- Fract (...) : Int (...) - & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...) - & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...) - & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...) - & "fscale ", -- 2**(Fract (...) + Int (...)) - Outputs => Double'Asm_Output ("=t", Result), - Inputs => - (Double'Asm_Input ("0", X), - Double'Asm_Input ("u", Y))); - return Result; - end Logarithmic_Pow; - - --------- - -- Pow -- - --------- - - function Pow (X, Y : Double) return Double is - type Mantissa_Type is mod 2**Double'Machine_Mantissa; - -- Modular type that can hold all bits of the mantissa of Double - - -- For negative exponents, do divide at the end of the processing - - Negative_Y : constant Boolean := Y < 0.0; - Abs_Y : constant Double := abs Y; - - -- During this function the following invariant is kept: - -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor - - Base : Double := X; - - Exp_High : Double := Double'Floor (Abs_Y); - Exp_Mid : Double; - Exp_Low : Double; - Exp_Int : Mantissa_Type; - - Factor : Double := 1.0; - - begin - -- Select algorithm for calculating Pow (integer cases fall through) - - if Exp_High >= 2.0**Double'Machine_Mantissa then - - -- In case of Y that is IEEE infinity, just raise constraint error - - if Exp_High > Double'Safe_Last then - raise Constraint_Error; - end if; - - -- Large values of Y are even integers and will stay integer - -- after division by two. - - loop - -- Exp_Mid and Exp_Low are zero, so - -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2) - - Exp_High := Exp_High / 2.0; - Base := Base * Base; - exit when Exp_High < 2.0**Double'Machine_Mantissa; - end loop; - - elsif Exp_High /= Abs_Y then - Exp_Low := Abs_Y - Exp_High; - Factor := 1.0; - - if Exp_Low /= 0.0 then - - -- Exp_Low now is in interval (0.0, 1.0) - -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0; - - Exp_Mid := 0.0; - Exp_Low := Exp_Low - Exp_Mid; - - if Exp_Low >= 0.5 then - Factor := Sqrt (X); - Exp_Low := Exp_Low - 0.5; -- exact - - if Exp_Low >= 0.25 then - Factor := Factor * Sqrt (Factor); - Exp_Low := Exp_Low - 0.25; -- exact - end if; - - elsif Exp_Low >= 0.25 then - Factor := Sqrt (Sqrt (X)); - Exp_Low := Exp_Low - 0.25; -- exact - end if; - - -- Exp_Low now is in interval (0.0, 0.25) - - -- This means it is safe to call Logarithmic_Pow - -- for the remaining part. - - Factor := Factor * Logarithmic_Pow (X, Exp_Low); - end if; - - elsif X = 0.0 then - return 0.0; - end if; - - -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa - - Exp_Int := Mantissa_Type (Exp_High); - - -- Standard way for processing integer powers > 0 - - while Exp_Int > 1 loop - if (Exp_Int and 1) = 1 then - - -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0 - - Factor := Factor * Base; - end if; - - -- Exp_Int is even and Exp_Int > 0, so - -- Base**Y = (Base**2)**(Exp_Int / 2) - - Base := Base * Base; - Exp_Int := Exp_Int / 2; - end loop; - - -- Exp_Int = 1 or Exp_Int = 0 - - if Exp_Int = 1 then - Factor := Base * Factor; - end if; - - if Negative_Y then - Factor := 1.0 / Factor; - end if; - - return Factor; - end Pow; - - --------- - -- Sin -- - --------- - - function Sin (X : Double) return Double is - Reduced_X : Double := X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 1 => - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 2 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", -Reduced_X)); - - when 3 => - Asm (Template => "fcos ; fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end case; - - else - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Sin; - - --------- - -- Tan -- - --------- - - function Tan (X : Double) return Double is - Reduced_X : Double := X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - if Quadrant mod 2 = 0 then - Asm (Template => "fptan" & NL - & "ffree %%st(0)" & NL - & "fincstp", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - else - Asm (Template => "fsincos" & NL - & "fdivp %%st, %%st(1)" & NL - & "fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - else - Asm (Template => - "fptan " & NL - & "ffree %%st(0) " & NL - & "fincstp ", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Tan; - - ---------- - -- Sinh -- - ---------- - - function Sinh (X : Double) return Double is - begin - -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0 - - if abs X < 25.0 then - return (Exp (X) - Exp (-X)) / 2.0; - else - return Exp (X) / 2.0; - end if; - end Sinh; - - ---------- - -- Cosh -- - ---------- - - function Cosh (X : Double) return Double is - begin - -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0 - - if abs X < 22.0 then - return (Exp (X) + Exp (-X)) / 2.0; - else - return Exp (X) / 2.0; - end if; - end Cosh; - - ---------- - -- Tanh -- - ---------- - - function Tanh (X : Double) return Double is - begin - -- Return the Hyperbolic Tangent of x - - -- x -x - -- e - e Sinh (X) - -- Tanh (X) is defined to be ----------- = -------- - -- x -x Cosh (X) - -- e + e - - if abs X > 23.0 then - return Double'Copy_Sign (1.0, X); - end if; - - return 1.0 / (1.0 + Exp (-(2.0 * X))) - 1.0 / (1.0 + Exp (2.0 * X)); - end Tanh; - -end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-stobbu.adb b/gcc/ada/libgnat/a-stobbu.adb index 64f2b6d..fba591d 100644 --- a/gcc/ada/libgnat/a-stobbu.adb +++ b/gcc/ada/libgnat/a-stobbu.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - package body Ada.Strings.Text_Output.Bit_Buckets is type Bit_Bucket_Type is new Sink with null record; diff --git a/gcc/ada/libgnat/a-stobbu.ads b/gcc/ada/libgnat/a-stobbu.ads index d2b1011..027e711 100644 --- a/gcc/ada/libgnat/a-stobbu.ads +++ b/gcc/ada/libgnat/a-stobbu.ads @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - package Ada.Strings.Text_Output.Bit_Buckets is function Bit_Bucket return Sink_Access; end Ada.Strings.Text_Output.Bit_Buckets; diff --git a/gcc/ada/libgnat/a-stobfi.adb b/gcc/ada/libgnat/a-stobfi.adb index 91edf3f..dd485ba 100644 --- a/gcc/ada/libgnat/a-stobfi.adb +++ b/gcc/ada/libgnat/a-stobfi.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; package body Ada.Strings.Text_Output.Basic_Files is use type OS.File_Descriptor; diff --git a/gcc/ada/libgnat/a-stobfi.ads b/gcc/ada/libgnat/a-stobfi.ads index a2892f0..65e8e24 100644 --- a/gcc/ada/libgnat/a-stobfi.ads +++ b/gcc/ada/libgnat/a-stobfi.ads @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - private with GNAT.OS_Lib; package Ada.Strings.Text_Output.Basic_Files is -- Normally, you should use Ada.Strings.Text_Output.Files, which diff --git a/gcc/ada/libgnat/a-stoubu.adb b/gcc/ada/libgnat/a-stoubu.adb index f563ea5..9fb6c5a 100644 --- a/gcc/ada/libgnat/a-stoubu.adb +++ b/gcc/ada/libgnat/a-stoubu.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Unchecked_Deallocation; with Ada.Strings.UTF_Encoding.Strings; with Ada.Strings.UTF_Encoding.Wide_Strings; diff --git a/gcc/ada/libgnat/a-stoubu.ads b/gcc/ada/libgnat/a-stoubu.ads index 519e473..faec897 100644 --- a/gcc/ada/libgnat/a-stoubu.ads +++ b/gcc/ada/libgnat/a-stoubu.ads @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - package Ada.Strings.Text_Output.Buffers is type Buffer (<>) is new Sink with private; diff --git a/gcc/ada/libgnat/a-stoufi.adb b/gcc/ada/libgnat/a-stoufi.adb index 90c03da..34086bb 100644 --- a/gcc/ada/libgnat/a-stoufi.adb +++ b/gcc/ada/libgnat/a-stoufi.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; package body Ada.Strings.Text_Output.Files is use type OS.File_Descriptor; diff --git a/gcc/ada/libgnat/a-stoufi.ads b/gcc/ada/libgnat/a-stoufi.ads index a94124b..0bff45a 100644 --- a/gcc/ada/libgnat/a-stoufi.ads +++ b/gcc/ada/libgnat/a-stoufi.ads @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - private with GNAT.OS_Lib; private with Ada.Finalization; package Ada.Strings.Text_Output.Files is diff --git a/gcc/ada/libgnat/a-stoufo.adb b/gcc/ada/libgnat/a-stoufo.adb index 58d7f5a..f80b30a 100644 --- a/gcc/ada/libgnat/a-stoufo.adb +++ b/gcc/ada/libgnat/a-stoufo.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Ada.Strings.Text_Output.Files; with Ada.Strings.Text_Output.Buffers; use Ada.Strings.Text_Output.Buffers; with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; diff --git a/gcc/ada/libgnat/a-stoufo.ads b/gcc/ada/libgnat/a-stoufo.ads index a31ed2d..3b44bd8 100644 --- a/gcc/ada/libgnat/a-stoufo.ads +++ b/gcc/ada/libgnat/a-stoufo.ads @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - package Ada.Strings.Text_Output.Formatting is -- Template-based output, based loosely on C's printf family. Unlike diff --git a/gcc/ada/libgnat/a-stouut.adb b/gcc/ada/libgnat/a-stouut.adb index 89d6c6e..b5a8f97 100644 --- a/gcc/ada/libgnat/a-stouut.adb +++ b/gcc/ada/libgnat/a-stouut.adb @@ -29,9 +29,8 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; + package body Ada.Strings.Text_Output.Utils is procedure Put_Octet (S : in out Sink'Class; Item : Character) with Inline; diff --git a/gcc/ada/libgnat/a-stouut.ads b/gcc/ada/libgnat/a-stouut.ads index d781a06..28d7eca 100644 --- a/gcc/ada/libgnat/a-stouut.ads +++ b/gcc/ada/libgnat/a-stouut.ads @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - package Ada.Strings.Text_Output.Utils with Preelaborate is -- This package provides utility functions on Sink'Class. These are diff --git a/gcc/ada/libgnat/a-strsto.ads b/gcc/ada/libgnat/a-strsto.ads index 1e2814b..ae38b2d 100644 --- a/gcc/ada/libgnat/a-strsto.ads +++ b/gcc/ada/libgnat/a-strsto.ads @@ -30,7 +30,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; package Ada.Streams.Storage with Pure is type Storage_Stream_Type is abstract new Root_Stream_Type with private; diff --git a/gcc/ada/libgnat/a-strunb.adb b/gcc/ada/libgnat/a-strunb.adb index 0164c79..988de42 100644 --- a/gcc/ada/libgnat/a-strunb.adb +++ b/gcc/ada/libgnat/a-strunb.adb @@ -35,6 +35,19 @@ with Ada.Unchecked_Deallocation; package body Ada.Strings.Unbounded is + function Sum (Left : Natural; Right : Integer) return Natural with Inline; + -- Returns summary of Left and Right, raise Constraint_Error on overflow + + function Mul (Left, Right : Natural) return Natural with Inline; + -- Returns multiplication of Left and Right, raise Constraint_Error on + -- overflow. + + function Saturated_Sum (Left : Natural; Right : Integer) return Natural; + -- Returns summary of Left and Right or Natural'Last on overflow + + function Saturated_Mul (Left, Right : Natural) return Natural; + -- Returns multiplication of Left and Right or Natural'Last on overflow + --------- -- "&" -- --------- @@ -48,7 +61,7 @@ package body Ada.Strings.Unbounded is Result : Unbounded_String; begin - Result.Last := L_Length + R_Length; + Result.Last := Sum (L_Length, R_Length); Result.Reference := new String (1 .. Result.Last); @@ -68,7 +81,7 @@ package body Ada.Strings.Unbounded is Result : Unbounded_String; begin - Result.Last := L_Length + Right'Length; + Result.Last := Sum (L_Length, Right'Length); Result.Reference := new String (1 .. Result.Last); @@ -86,7 +99,7 @@ package body Ada.Strings.Unbounded is Result : Unbounded_String; begin - Result.Last := Left'Length + R_Length; + Result.Last := Sum (Left'Length, R_Length); Result.Reference := new String (1 .. Result.Last); @@ -104,7 +117,7 @@ package body Ada.Strings.Unbounded is Result : Unbounded_String; begin - Result.Last := Left.Last + 1; + Result.Last := Sum (Left.Last, 1); Result.Reference := new String (1 .. Result.Last); @@ -122,7 +135,7 @@ package body Ada.Strings.Unbounded is Result : Unbounded_String; begin - Result.Last := Right.Last + 1; + Result.Last := Sum (Right.Last, 1); Result.Reference := new String (1 .. Result.Last); Result.Reference (1) := Left; @@ -142,7 +155,7 @@ package body Ada.Strings.Unbounded is Result : Unbounded_String; begin - Result.Last := Left; + Result.Last := Left; Result.Reference := new String (1 .. Left); for J in Result.Reference'Range loop @@ -161,7 +174,7 @@ package body Ada.Strings.Unbounded is Result : Unbounded_String; begin - Result.Last := Left * Len; + Result.Last := Mul (Left, Len); Result.Reference := new String (1 .. Result.Last); @@ -183,7 +196,7 @@ package body Ada.Strings.Unbounded is Result : Unbounded_String; begin - Result.Last := Left * Len; + Result.Last := Mul (Left, Len); Result.Reference := new String (1 .. Result.Last); @@ -718,6 +731,16 @@ package body Ada.Strings.Unbounded is return Source.Last; end Length; + --------- + -- Mul -- + --------- + + function Mul (Left, Right : Natural) return Natural is + pragma Unsuppress (Overflow_Check); + begin + return Left * Right; + end Mul; + --------------- -- Overwrite -- --------------- @@ -783,10 +806,12 @@ package body Ada.Strings.Unbounded is if Chunk_Size > S_Length - Source.Last then declare New_Size : constant Positive := - S_Length + Chunk_Size + (S_Length / Growth_Factor); + Saturated_Sum + (Sum (S_Length, Chunk_Size), S_Length / Growth_Factor); New_Rounded_Up_Size : constant Positive := - ((New_Size - 1) / Min_Mul_Alloc + 1) * Min_Mul_Alloc; + Saturated_Mul + ((New_Size - 1) / Min_Mul_Alloc + 1, Min_Mul_Alloc); Tmp : constant String_Access := new String (1 .. New_Rounded_Up_Size); @@ -847,6 +872,30 @@ package body Ada.Strings.Unbounded is Free (Old); end Replace_Slice; + ------------------- + -- Saturated_Mul -- + ------------------- + + function Saturated_Mul (Left, Right : Natural) return Natural is + begin + return Mul (Left, Right); + exception + when Constraint_Error => + return Natural'Last; + end Saturated_Mul; + + ----------------- + -- Saturated_Sum -- + ----------------- + + function Saturated_Sum (Left : Natural; Right : Integer) return Natural is + begin + return Sum (Left, Right); + exception + when Constraint_Error => + return Natural'Last; + end Saturated_Sum; + -------------------------- -- Set_Unbounded_String -- -------------------------- @@ -882,6 +931,16 @@ package body Ada.Strings.Unbounded is end if; end Slice; + --------- + -- Sum -- + --------- + + function Sum (Left : Natural; Right : Integer) return Natural is + pragma Unsuppress (Overflow_Check); + begin + return Left + Right; + end Sum; + ---------- -- Tail -- ---------- @@ -1047,7 +1106,7 @@ package body Ada.Strings.Unbounded is High : Natural) return Unbounded_String is begin - if Low > Source.Last + 1 or else High > Source.Last then + if Low - 1 > Source.Last or else High > Source.Last then raise Index_Error; else return To_Unbounded_String (Source.Reference.all (Low .. High)); @@ -1061,7 +1120,7 @@ package body Ada.Strings.Unbounded is High : Natural) is begin - if Low > Source.Last + 1 or else High > Source.Last then + if Low - 1 > Source.Last or else High > Source.Last then raise Index_Error; else Target := To_Unbounded_String (Source.Reference.all (Low .. High)); diff --git a/gcc/ada/libgnat/a-strunb__shared.adb b/gcc/ada/libgnat/a-strunb__shared.adb index 272ef43..0ff34d8 100644 --- a/gcc/ada/libgnat/a-strunb__shared.adb +++ b/gcc/ada/libgnat/a-strunb__shared.adb @@ -56,6 +56,18 @@ package body Ada.Strings.Unbounded is -- allocated memory segments to use memory effectively by Append/Insert/etc -- operations. + function Sum (Left : Natural; Right : Integer) return Natural with Inline; + -- Returns summary of Left and Right, raise Constraint_Error on overflow + + function Mul (Left, Right : Natural) return Natural with Inline; + -- Returns multiplication of Left and Right, raise Constraint_Error on + -- overflow + + function Allocate + (Length, Growth : Natural) return not null Shared_String_Access; + -- Allocates new Shared_String with at least specified Length plus optional + -- Growth. + --------- -- "&" -- --------- @@ -66,7 +78,7 @@ package body Ada.Strings.Unbounded is is LR : constant Shared_String_Access := Left.Reference; RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := LR.Last + RR.Last; + DL : constant Natural := Sum (LR.Last, RR.Last); DR : Shared_String_Access; begin @@ -104,7 +116,7 @@ package body Ada.Strings.Unbounded is Right : String) return Unbounded_String is LR : constant Shared_String_Access := Left.Reference; - DL : constant Natural := LR.Last + Right'Length; + DL : constant Natural := Sum (LR.Last, Right'Length); DR : Shared_String_Access; begin @@ -136,7 +148,7 @@ package body Ada.Strings.Unbounded is Right : Unbounded_String) return Unbounded_String is RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := Left'Length + RR.Last; + DL : constant Natural := Sum (Left'Length, RR.Last); DR : Shared_String_Access; begin @@ -168,7 +180,7 @@ package body Ada.Strings.Unbounded is Right : Character) return Unbounded_String is LR : constant Shared_String_Access := Left.Reference; - DL : constant Natural := LR.Last + 1; + DL : constant Natural := Sum (LR.Last, 1); DR : Shared_String_Access; begin @@ -185,7 +197,7 @@ package body Ada.Strings.Unbounded is Right : Unbounded_String) return Unbounded_String is RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := 1 + RR.Last; + DL : constant Natural := Sum (1, RR.Last); DR : Shared_String_Access; begin @@ -232,7 +244,7 @@ package body Ada.Strings.Unbounded is (Left : Natural; Right : String) return Unbounded_String is - DL : constant Natural := Left * Right'Length; + DL : constant Natural := Mul (Left, Right'Length); DR : Shared_String_Access; K : Positive; @@ -264,7 +276,7 @@ package body Ada.Strings.Unbounded is Right : Unbounded_String) return Unbounded_String is RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := Left * RR.Last; + DL : constant Natural := Mul (Left, RR.Last); DR : Shared_String_Access; K : Positive; @@ -480,13 +492,16 @@ package body Ada.Strings.Unbounded is function Aligned_Max_Length (Max_Length : Natural) return Natural is Static_Size : constant Natural := - Empty_Shared_String'Size / Standard'Storage_Unit; - -- Total size of all static components - + Empty_Shared_String'Size / Standard'Storage_Unit; + -- Total size of all Shared_String static components begin - return - ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc - - Static_Size; + if Max_Length > Natural'Last - Static_Size then + return Natural'Last; + else + return + ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc + - Static_Size; + end if; end Aligned_Max_Length; -------------- @@ -509,6 +524,23 @@ package body Ada.Strings.Unbounded is end if; end Allocate; + -------------- + -- Allocate -- + -------------- + + function Allocate + (Length, Growth : Natural) return not null Shared_String_Access is + begin + if Natural'Last - Growth < Length then + -- Then Length + Growth would be more than Natural'Last + + return new Shared_String (Integer'Last); + + else + return Allocate (Length + Growth); + end if; + end Allocate; + ------------ -- Append -- ------------ @@ -519,7 +551,7 @@ package body Ada.Strings.Unbounded is is SR : constant Shared_String_Access := Source.Reference; NR : constant Shared_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; + DL : constant Natural := Sum (SR.Last, NR.Last); DR : Shared_String_Access; begin @@ -544,7 +576,7 @@ package body Ada.Strings.Unbounded is -- Otherwise, allocate new one and fill it else - DR := Allocate (DL + DL / Growth_Factor); + DR := Allocate (DL, DL / Growth_Factor); DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); DR.Last := DL; @@ -558,7 +590,7 @@ package body Ada.Strings.Unbounded is New_Item : String) is SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; + DL : constant Natural := Sum (SR.Last, New_Item'Length); DR : Shared_String_Access; begin @@ -576,7 +608,7 @@ package body Ada.Strings.Unbounded is -- Otherwise, allocate new one and fill it else - DR := Allocate (DL + DL / Growth_Factor); + DR := Allocate (DL, DL / Growth_Factor); DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); DR.Data (SR.Last + 1 .. DL) := New_Item; DR.Last := DL; @@ -590,20 +622,20 @@ package body Ada.Strings.Unbounded is New_Item : Character) is SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; + DL : constant Natural := Sum (SR.Last, 1); DR : Shared_String_Access; begin -- Try to reuse existing shared string - if Can_Be_Reused (SR, SR.Last + 1) then + if Can_Be_Reused (SR, DL) then SR.Data (SR.Last + 1) := New_Item; SR.Last := SR.Last + 1; -- Otherwise, allocate new one and fill it else - DR := Allocate (DL + DL / Growth_Factor); + DR := Allocate (DL, DL / Growth_Factor); DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); DR.Data (DL) := New_Item; DR.Last := DL; @@ -1089,7 +1121,7 @@ package body Ada.Strings.Unbounded is -- Otherwise, allocate new shared string and fill it else - DR := Allocate (DL + DL / Growth_Factor); + DR := Allocate (DL, DL / Growth_Factor); DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; DR.Data (Before + New_Item'Length .. DL) := @@ -1138,7 +1170,7 @@ package body Ada.Strings.Unbounded is -- Otherwise, allocate new shared string and fill it else - DR := Allocate (DL + DL / Growth_Factor); + DR := Allocate (DL, DL / Growth_Factor); DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; DR.Data (Before + New_Item'Length .. DL) := @@ -1158,6 +1190,16 @@ package body Ada.Strings.Unbounded is return Source.Reference.Last; end Length; + --------- + -- Mul -- + --------- + + function Mul (Left, Right : Natural) return Natural is + pragma Unsuppress (Overflow_Check); + begin + return Left * Right; + end Mul; + --------------- -- Overwrite -- --------------- @@ -1178,7 +1220,7 @@ package body Ada.Strings.Unbounded is raise Index_Error; end if; - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + DL := Integer'Max (SR.Last, Sum (Position - 1, New_Item'Length)); -- Result is empty string, reuse empty shared string @@ -1329,7 +1371,8 @@ package body Ada.Strings.Unbounded is -- Do replace operation when removed slice is not empty if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + DL := Sum (SR.Last, + By'Length + Low - Integer'Min (High, SR.Last) - 1); -- This is the number of characters remaining in the string after -- replacing the slice. @@ -1473,6 +1516,16 @@ package body Ada.Strings.Unbounded is end if; end Slice; + --------- + -- Sum -- + --------- + + function Sum (Left : Natural; Right : Integer) return Natural is + pragma Unsuppress (Overflow_Check); + begin + return Left + Right; + end Sum; + ---------- -- Tail -- ---------- @@ -1996,7 +2049,7 @@ package body Ada.Strings.Unbounded is begin -- Check bounds - if Low > SR.Last + 1 or else High > SR.Last then + if Low - 1 > SR.Last or else High > SR.Last then raise Index_Error; -- Result is empty slice, reuse empty shared string @@ -2030,7 +2083,7 @@ package body Ada.Strings.Unbounded is begin -- Check bounds - if Low > SR.Last + 1 or else High > SR.Last then + if Low - 1 > SR.Last or else High > SR.Last then raise Index_Error; -- Result is empty slice, reuse empty shared string diff --git a/gcc/ada/libgnat/a-ststbo.adb b/gcc/ada/libgnat/a-ststbo.adb index 4bd3c17..16c6d00 100644 --- a/gcc/ada/libgnat/a-ststbo.adb +++ b/gcc/ada/libgnat/a-ststbo.adb @@ -26,7 +26,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; package body Ada.Streams.Storage.Bounded is ---------- diff --git a/gcc/ada/libgnat/a-ststbo.ads b/gcc/ada/libgnat/a-ststbo.ads index 1ce6d90..fe41c2c 100644 --- a/gcc/ada/libgnat/a-ststbo.ads +++ b/gcc/ada/libgnat/a-ststbo.ads @@ -30,7 +30,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; package Ada.Streams.Storage.Bounded with Pure is type Stream_Type (Max_Elements : Stream_Element_Count) is diff --git a/gcc/ada/libgnat/a-ststun.adb b/gcc/ada/libgnat/a-ststun.adb index f2f433b..cf3a250 100644 --- a/gcc/ada/libgnat/a-ststun.adb +++ b/gcc/ada/libgnat/a-ststun.adb @@ -26,8 +26,8 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; with Ada.Unchecked_Deallocation; + package body Ada.Streams.Storage.Unbounded is procedure Free is new Ada.Unchecked_Deallocation diff --git a/gcc/ada/libgnat/a-ststun.ads b/gcc/ada/libgnat/a-ststun.ads index 2f01fa0..95aca9b 100644 --- a/gcc/ada/libgnat/a-ststun.ads +++ b/gcc/ada/libgnat/a-ststun.ads @@ -30,8 +30,8 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; private with Ada.Finalization; + package Ada.Streams.Storage.Unbounded with Preelaborate is type Stream_Type is new Storage_Stream_Type with private with diff --git a/gcc/ada/libgnat/a-stteou.ads b/gcc/ada/libgnat/a-stteou.ads index f4b8966..924b550 100644 --- a/gcc/ada/libgnat/a-stteou.ads +++ b/gcc/ada/libgnat/a-stteou.ads @@ -29,10 +29,9 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - with Ada.Strings.UTF_Encoding; with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; + package Ada.Strings.Text_Output with Preelaborate is -- This package provides a "Sink" abstraction, to which characters of type diff --git a/gcc/ada/libgnat/a-wichha.adb b/gcc/ada/libgnat/a-wichha.adb index 7531ef6..feccc23 100644 --- a/gcc/ada/libgnat/a-wichha.adb +++ b/gcc/ada/libgnat/a-wichha.adb @@ -124,6 +124,13 @@ package body Ada.Wide_Characters.Handling is function Is_Mark (Item : Wide_Character) return Boolean renames Ada.Wide_Characters.Unicode.Is_Mark; + ------------- + -- Is_NFKC -- + ------------- + + function Is_NFKC (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_NFKC; + --------------------- -- Is_Other_Format -- --------------------- diff --git a/gcc/ada/libgnat/a-wichha.ads b/gcc/ada/libgnat/a-wichha.ads index bb9452f..23eb468 100644 --- a/gcc/ada/libgnat/a-wichha.ads +++ b/gcc/ada/libgnat/a-wichha.ads @@ -101,6 +101,12 @@ package Ada.Wide_Characters.Handling is -- Returns True if the Wide_Character designated by Item is categorized as -- separator_space, otherwise returns False. + function Is_NFKC (Item : Wide_Character) return Boolean; + pragma Inline (Is_NFKC); + -- Returns True if the Wide_Character designated by Item could be present + -- in a string normalized to Normalization Form KC (as defined by Clause + -- 21 of ISO/IEC 10646:2017), otherwise returns False. + function Is_Graphic (Item : Wide_Character) return Boolean; pragma Inline (Is_Graphic); -- Returns True if the Wide_Character designated by Item is categorized as diff --git a/gcc/ada/libgnat/a-wichun.adb b/gcc/ada/libgnat/a-wichun.adb index cfd84da..09cbad2 100644 --- a/gcc/ada/libgnat/a-wichun.adb +++ b/gcc/ada/libgnat/a-wichun.adb @@ -116,6 +116,15 @@ package body Ada.Wide_Characters.Unicode is return G.Is_UTF_32_Non_Graphic (G.Category (C)); end Is_Non_Graphic; + ------------- + -- Is_NFKC -- + ------------- + + function Is_NFKC (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_NFKC (Wide_Character'Pos (U)); + end Is_NFKC; + -------------- -- Is_Other -- -------------- diff --git a/gcc/ada/libgnat/a-wichun.ads b/gcc/ada/libgnat/a-wichun.ads index c9eb938..9e42749 100644 --- a/gcc/ada/libgnat/a-wichun.ads +++ b/gcc/ada/libgnat/a-wichun.ads @@ -131,7 +131,7 @@ package Ada.Wide_Characters.Unicode is pragma Inline (Is_Other); -- Returns true iff U is an other format character, which means that it -- can be used to extend an identifier, but is ignored for the purposes of - -- matching of identiers, or if C is one of the corresponding categories, + -- matching of identifiers, or if C is one of the corresponding categories, -- which are the following: -- Other, Format (Cf) @@ -150,6 +150,12 @@ package Ada.Wide_Characters.Unicode is -- of the corresponding categories, which are the following: -- Separator, Space (Zs) + function Is_NFKC (U : Wide_Character) return Boolean; + pragma Inline (Is_NFKC); + -- Returns True if the Wide_Character designated by U could be present + -- in a string normalized to Normalization Form KC (as defined by Clause + -- 21 of ISO/IEC 10646:2017), otherwise returns False. + function Is_Non_Graphic (U : Wide_Character) return Boolean; function Is_Non_Graphic (C : Category) return Boolean; pragma Inline (Is_Non_Graphic); diff --git a/gcc/ada/libgnat/a-zchhan.adb b/gcc/ada/libgnat/a-zchhan.adb index 4fd7eba..6930121 100644 --- a/gcc/ada/libgnat/a-zchhan.adb +++ b/gcc/ada/libgnat/a-zchhan.adb @@ -108,6 +108,13 @@ package body Ada.Wide_Wide_Characters.Handling is function Is_Mark (Item : Wide_Wide_Character) return Boolean renames Ada.Wide_Wide_Characters.Unicode.Is_Mark; + ------------- + -- Is_NFKC -- + ------------- + + function Is_NFKC (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_NFKC; + --------------------- -- Is_Other_Format -- --------------------- diff --git a/gcc/ada/libgnat/a-zchhan.ads b/gcc/ada/libgnat/a-zchhan.ads index 354452b..74fab2a 100644 --- a/gcc/ada/libgnat/a-zchhan.ads +++ b/gcc/ada/libgnat/a-zchhan.ads @@ -98,6 +98,12 @@ package Ada.Wide_Wide_Characters.Handling is -- Returns True if the Wide_Wide_Character designated by Item is -- categorized as separator_space, otherwise returns false. + function Is_NFKC (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_NFKC); + -- Returns True if the Wide_Wide_Character designated by Item could be + -- present in a string normalized to Normalization Form KC (as defined by + -- Clause 21 of ISO/IEC 10646:2017), otherwise returns False. + function Is_Graphic (Item : Wide_Wide_Character) return Boolean; pragma Inline (Is_Graphic); -- Returns True if the Wide_Wide_Character designated by Item is diff --git a/gcc/ada/libgnat/a-zchuni.adb b/gcc/ada/libgnat/a-zchuni.adb index b754af9..203c3aa 100644 --- a/gcc/ada/libgnat/a-zchuni.adb +++ b/gcc/ada/libgnat/a-zchuni.adb @@ -107,6 +107,15 @@ package body Ada.Wide_Wide_Characters.Unicode is return G.Is_UTF_32_Non_Graphic (G.Category (C)); end Is_Non_Graphic; + ------------- + -- Is_NFKC -- + ------------- + + function Is_NFKC (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_NFKC (Wide_Wide_Character'Pos (U)); + end Is_NFKC; + -------------- -- Is_Other -- -------------- diff --git a/gcc/ada/libgnat/a-zchuni.ads b/gcc/ada/libgnat/a-zchuni.ads index 162d18d..7f4a30b 100644 --- a/gcc/ada/libgnat/a-zchuni.ads +++ b/gcc/ada/libgnat/a-zchuni.ads @@ -147,6 +147,12 @@ package Ada.Wide_Wide_Characters.Unicode is -- of the corresponding categories, which are the following: -- Separator, Space (Zs) + function Is_NFKC (U : Wide_Wide_Character) return Boolean; + pragma Inline (Is_NFKC); + -- Returns True if the Wide_Wide_Character designated by U could be present + -- in a string normalized to Normalization Form KC (as defined by Clause + -- 21 of ISO/IEC 10646:2017), otherwise returns False. + function Is_Non_Graphic (U : Wide_Wide_Character) return Boolean; function Is_Non_Graphic (C : Category) return Boolean; pragma Inline (Is_Non_Graphic); diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb index da631e3..719d9a9 100644 --- a/gcc/ada/libgnat/g-socket.adb +++ b/gcc/ada/libgnat/g-socket.adb @@ -2062,8 +2062,11 @@ package body GNAT.Sockets is Close_Selector (S.all); Unchecked_Free (Local_S); end if; + exception when others => + Status := Completed; + if Selector = null then Close_Selector (S.all); Unchecked_Free (Local_S); diff --git a/gcc/ada/libgnat/s-aoinar.ads b/gcc/ada/libgnat/s-aoinar.ads index 17e5cdf..558754f 100644 --- a/gcc/ada/libgnat/s-aoinar.ads +++ b/gcc/ada/libgnat/s-aoinar.ads @@ -33,8 +33,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - generic type Atomic_Type is range <> with Atomic; package System.Atomic_Operations.Integer_Arithmetic diff --git a/gcc/ada/libgnat/s-aomoar.ads b/gcc/ada/libgnat/s-aomoar.ads index f6057ad..4062d1a 100644 --- a/gcc/ada/libgnat/s-aomoar.ads +++ b/gcc/ada/libgnat/s-aomoar.ads @@ -33,8 +33,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - generic type Atomic_Type is mod <> with Atomic; package System.Atomic_Operations.Modular_Arithmetic diff --git a/gcc/ada/libgnat/s-atopex.ads b/gcc/ada/libgnat/s-atopex.ads index 11d850e..996883c 100644 --- a/gcc/ada/libgnat/s-atopex.ads +++ b/gcc/ada/libgnat/s-atopex.ads @@ -33,13 +33,10 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; - generic type Atomic_Type is private with Atomic; package System.Atomic_Operations.Exchange with Pure --- Blocking is function Atomic_Exchange (Item : aliased in out Atomic_Type; diff --git a/gcc/ada/libgnat/s-genbig.adb b/gcc/ada/libgnat/s-genbig.adb index 2f6bdd5c..71aff9b 100644 --- a/gcc/ada/libgnat/s-genbig.adb +++ b/gcc/ada/libgnat/s-genbig.adb @@ -98,6 +98,7 @@ package body System.Generic_Bignums is -- Given a digit vector and sign, allocate and construct a big integer -- value. Note that X may have leading zeroes which must be removed, and if -- the result is zero, the sign is forced positive. + -- If X is too big, Storage_Error is raised. function "**" (X : Bignum; Y : SD) return Big_Integer; -- Exponentiation routine where we know right operand is one word @@ -274,32 +275,18 @@ package body System.Generic_Bignums is XY2 : aliased Big_Integer := X ** (Y / 2); XY2S : aliased Big_Integer := Big_Mul (To_Bignum (XY2), To_Bignum (XY2)); - Res : Big_Integer; begin Free_Big_Integer (XY2); - -- Raise storage error if intermediate value is getting too - -- large, which we arbitrarily define as 200 words for now. - -- ??? Consider putting a limit instead in a wrapper of - -- Allocate_Big_Integer and update all calls to - -- Allocate_Big_Integer to call this wrapper, to catch all such - -- cases. - - if To_Bignum (XY2S).Len > 200 then - Free_Big_Integer (XY2S); - raise Storage_Error with - "exponentiation result is too large"; - end if; - - -- Otherwise take care of even/odd cases - if (Y and 1) = 0 then return XY2S; else - Res := Big_Mul (To_Bignum (XY2S), X); - Free_Big_Integer (XY2S); - return Res; + return Res : constant Big_Integer := + Big_Mul (To_Bignum (XY2S), X) + do + Free_Big_Integer (XY2S); + end return; end if; end; end case; @@ -1108,6 +1095,8 @@ package body System.Generic_Bignums is -- Normalize -- --------------- + Bignum_Limit : constant := 200; + function Normalize (X : Digit_Vector; Neg : Boolean := False) return Big_Integer @@ -1120,6 +1109,10 @@ package body System.Generic_Bignums is J := J + 1; end loop; + if X'Last - J > Bignum_Limit then + raise Storage_Error with "big integer limit exceeded"; + end if; + return Allocate_Big_Integer (X (J .. X'Last), J <= X'Last and then Neg); end Normalize; diff --git a/gcc/ada/libgnat/s-putaim.adb b/gcc/ada/libgnat/s-putaim.adb index ed8cfe4..08fa7b7 100644 --- a/gcc/ada/libgnat/s-putaim.adb +++ b/gcc/ada/libgnat/s-putaim.adb @@ -29,7 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; with Unchecked_Conversion; with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output; diff --git a/gcc/ada/libgnat/s-putaim.ads b/gcc/ada/libgnat/s-putaim.ads index c06b751..b4dd8c2 100644 --- a/gcc/ada/libgnat/s-putaim.ads +++ b/gcc/ada/libgnat/s-putaim.ads @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; with Ada.Strings.Text_Output; with Ada.Task_Identification; + package System.Put_Task_Images is -- This package contains subprograms that are called by the generated code diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb index 1b214bf..4ae612d 100644 --- a/gcc/ada/libgnat/s-putima.adb +++ b/gcc/ada/libgnat/s-putima.adb @@ -29,7 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; with Unchecked_Conversion; with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output; @@ -46,13 +45,14 @@ package body System.Put_Images is pragma Assert (Base in 2 .. 36); procedure Put_Image (S : in out Sink'Class; X : Integer_Type); procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type); + private + subtype Digit is Unsigned_Type range 0 .. Base - 1; end Generic_Integer_Images; package body Generic_Integer_Images is A : constant := Character'Pos ('a'); Z : constant := Character'Pos ('0'); - subtype Digit is Unsigned_Type range 0 .. Base - 1; function Digit_To_Character (X : Digit) return Character is (Character'Val (if X < 10 then X + Z else X + A - 10)); diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads index da62930..17e184a 100644 --- a/gcc/ada/libgnat/s-putima.ads +++ b/gcc/ada/libgnat/s-putima.ads @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2020; with Ada.Strings.Text_Output; with System.Unsigned_Types; + package System.Put_Images is -- This package contains subprograms that are called by the generated code @@ -47,6 +47,8 @@ package System.Put_Images is -- after them. See Exp_Put_Image in the compiler for details of these -- calls. + pragma Preelaborate; + subtype Sink is Ada.Strings.Text_Output.Sink; procedure Put_Image_Integer (S : in out Sink'Class; X : Integer); diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb index baf5cbe..01a6e91 100644 --- a/gcc/ada/libgnat/s-rannum.adb +++ b/gcc/ada/libgnat/s-rannum.adb @@ -86,6 +86,7 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Strings.Text_Output.Utils; with Ada.Unchecked_Conversion; with System.Random_Seed; @@ -639,6 +640,16 @@ is return Result; end Image; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Strings.Text_Output.Sink'Class; V : State) is + begin + Strings.Text_Output.Utils.Put_String (S, Image (V)); + end Put_Image; + ----------- -- Value -- ----------- diff --git a/gcc/ada/libgnat/s-rannum.ads b/gcc/ada/libgnat/s-rannum.ads index ed2d35e..1851b69 100644 --- a/gcc/ada/libgnat/s-rannum.ads +++ b/gcc/ada/libgnat/s-rannum.ads @@ -57,6 +57,8 @@ with Interfaces; +private with Ada.Strings.Text_Output; + package System.Random_Numbers with SPARK_Mode => Off is @@ -142,7 +144,10 @@ private -- Feedback distance from the current position subtype State_Val is Interfaces.Unsigned_32; - type State is array (0 .. N - 1) of State_Val; + type State is array (0 .. N - 1) of State_Val with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : State); type Writable_Access (Self : access Generator) is limited null record; -- Auxiliary type to make Generator a self-referential type diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads index b7969fb..afec9a4 100644 --- a/gcc/ada/libgnat/s-rident.ads +++ b/gcc/ada/libgnat/s-rident.ads @@ -62,10 +62,10 @@ -- then the binder could fail to recognize the R (restrictions line) in the -- ali file, leading to bind errors when restrictions were added or removed. --- The latest implementation avoids both this problem by using a named --- scheme for recording restrictions, rather than a positional scheme which --- fails completely if restrictions are added or subtracted. Now the worst --- that happens at bind time in inconsistent builds is that unrecognized +-- The latest implementation avoids this problem by using a named scheme +-- for recording restrictions, rather than a positional scheme that fails +-- completely if restrictions are added or subtracted. Now the worst that +-- happens at bind time in inconsistent builds is that unrecognized -- restrictions are ignored, and the consistency checking for restrictions -- might be incomplete, which is no big deal. @@ -104,6 +104,7 @@ package System.Rident is No_Dispatch, -- (RM H.4(19)) No_Dispatching_Calls, -- GNAT No_Dynamic_Attachment, -- Ada 2012 (RM E.7(10/3)) + No_Dynamic_CPU_Assignment, -- Ada 202x (RM D.7(10/3)) No_Dynamic_Priorities, -- (RM D.9(9)) No_Enumeration_Maps, -- GNAT No_Entry_Calls_In_Elaboration_Code, -- GNAT @@ -147,6 +148,7 @@ package System.Rident is No_Task_At_Interrupt_Priority, -- GNAT No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) No_Task_Termination, -- GNAT (Ravenscar) + No_Tasks_Unassigned_To_CPU, -- Ada 202x (D.7(10.10/4)) No_Tasking, -- GNAT No_Terminate_Alternatives, -- (RM D.7(6)) No_Unchecked_Access, -- (RM H.4(18)) @@ -438,6 +440,7 @@ package System.Rident is (No_Abort_Statements => True, No_Asynchronous_Control => True, No_Dynamic_Attachment => True, + No_Dynamic_CPU_Assignment => True, No_Dynamic_Priorities => True, No_Local_Protected_Objects => True, No_Protected_Type_Allocators => True, @@ -469,6 +472,7 @@ package System.Rident is (No_Abort_Statements => True, No_Asynchronous_Control => True, No_Dynamic_Attachment => True, + No_Dynamic_CPU_Assignment => True, No_Dynamic_Priorities => True, No_Entry_Queue => True, No_Local_Protected_Objects => True, @@ -511,6 +515,7 @@ package System.Rident is (No_Abort_Statements => True, No_Asynchronous_Control => True, No_Dynamic_Attachment => True, + No_Dynamic_CPU_Assignment => True, No_Dynamic_Priorities => True, No_Entry_Queue => True, No_Local_Protected_Objects => True, @@ -578,6 +583,7 @@ package System.Rident is (No_Abort_Statements => True, No_Asynchronous_Control => True, No_Dynamic_Attachment => True, + No_Dynamic_CPU_Assignment => True, No_Dynamic_Priorities => True, No_Local_Protected_Objects => True, No_Protected_Type_Allocators => True, @@ -616,6 +622,7 @@ package System.Rident is (No_Abort_Statements => True, No_Asynchronous_Control => True, No_Dynamic_Attachment => True, + No_Dynamic_CPU_Assignment => True, No_Dynamic_Priorities => True, No_Local_Protected_Objects => True, No_Protected_Type_Allocators => True, @@ -666,6 +673,7 @@ package System.Rident is (No_Abort_Statements => True, No_Asynchronous_Control => True, No_Dynamic_Attachment => True, + No_Dynamic_CPU_Assignment => True, No_Dynamic_Priorities => True, No_Entry_Queue => True, No_Local_Protected_Objects => True, diff --git a/gcc/ada/libgnat/s-secsta.ads b/gcc/ada/libgnat/s-secsta.ads index d06e97f..504c891 100644 --- a/gcc/ada/libgnat/s-secsta.ads +++ b/gcc/ada/libgnat/s-secsta.ads @@ -264,7 +264,7 @@ private Memory_Alignment : constant := Standard'Maximum_Alignment * 2; -- The memory alignment we will want to honor on every allocation. -- - -- At this stage, gigi assumes we can accomodate any alignment requirement + -- At this stage, gigi assumes we can accommodate any alignment requirement -- there might be on the data type for which the memory gets allocated (see -- build_call_alloc_dealloc). -- diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb index b643d3f..ff61cfb 100644 --- a/gcc/ada/libgnat/s-stposu.adb +++ b/gcc/ada/libgnat/s-stposu.adb @@ -117,11 +117,12 @@ package body System.Storage_Pools.Subpools is Is_Subpool_Allocation : constant Boolean := Pool in Root_Storage_Pool_With_Subpools'Class; - Master : Finalization_Master_Ptr := null; - N_Addr : Address; - N_Ptr : FM_Node_Ptr; - N_Size : Storage_Count; - Subpool : Subpool_Handle := null; + Master : Finalization_Master_Ptr := null; + N_Addr : Address; + N_Ptr : FM_Node_Ptr; + N_Size : Storage_Count; + Subpool : Subpool_Handle := null; + Lock_Taken : Boolean := False; Header_And_Padding : Storage_Offset; -- This offset includes the size of a FM_Node plus any additional @@ -205,6 +206,7 @@ package body System.Storage_Pools.Subpools is -- Read - allocation, finalization -- Write - finalization + Lock_Taken := True; Lock_Task.all; -- Do not allow the allocation of controlled objects while the @@ -322,6 +324,7 @@ package body System.Storage_Pools.Subpools is end if; Unlock_Task.all; + Lock_Taken := False; -- Non-controlled allocation @@ -335,7 +338,7 @@ package body System.Storage_Pools.Subpools is -- Unlock the task in case the allocation step failed and reraise the -- exception. - if Is_Controlled then + if Lock_Taken then Unlock_Task.all; end if; diff --git a/gcc/ada/libgnat/s-ststop.adb b/gcc/ada/libgnat/s-ststop.adb index d07342e..cc2a352 100644 --- a/gcc/ada/libgnat/s-ststop.adb +++ b/gcc/ada/libgnat/s-ststop.adb @@ -216,21 +216,25 @@ package body System.Strings.Stream_Ops is declare -- Determine the size in BITS of the block necessary to contain -- the whole string. + -- Since we are dealing with strings indexed by natural, there + -- is no risk of overflow when using a Long_Long_Integer. - Block_Size : constant Natural := - Integer (Item'Last - Item'First + 1) * ET_Size; + Block_Size : constant Long_Long_Integer := + Item'Length * Long_Long_Integer (ET_Size); -- Item can be larger than what the default block can store, - -- determine the number of whole reads necessary to read the + -- determine the number of whole writes necessary to output the -- string. - Blocks : constant Natural := Block_Size / Default_Block_Size; + Blocks : constant Natural := + Natural (Block_Size / Long_Long_Integer (Default_Block_Size)); -- The size of Item may not be a multiple of the default block - -- size, determine the size of the remaining chunk in BITS. + -- size, determine the size of the remaining chunk. Rem_Size : constant Natural := - Block_Size mod Default_Block_Size; + Natural + (Block_Size mod Long_Long_Integer (Default_Block_Size)); -- String indexes @@ -337,20 +341,25 @@ package body System.Strings.Stream_Ops is declare -- Determine the size in BITS of the block necessary to contain -- the whole string. + -- Since we are dealing with strings indexed by natural, there + -- is no risk of overflow when using a Long_Long_Integer. - Block_Size : constant Natural := Item'Length * ET_Size; + Block_Size : constant Long_Long_Integer := + Item'Length * Long_Long_Integer (ET_Size); -- Item can be larger than what the default block can store, -- determine the number of whole writes necessary to output the -- string. - Blocks : constant Natural := Block_Size / Default_Block_Size; + Blocks : constant Natural := + Natural (Block_Size / Long_Long_Integer (Default_Block_Size)); -- The size of Item may not be a multiple of the default block -- size, determine the size of the remaining chunk. Rem_Size : constant Natural := - Block_Size mod Default_Block_Size; + Natural + (Block_Size mod Long_Long_Integer (Default_Block_Size)); -- String indexes diff --git a/gcc/ada/libgnat/s-ststop.ads b/gcc/ada/libgnat/s-ststop.ads index 321460b..5f35fed 100644 --- a/gcc/ada/libgnat/s-ststop.ads +++ b/gcc/ada/libgnat/s-ststop.ads @@ -53,7 +53,7 @@ -- or -- String_Output_Blk_IO (Some_Stream, Some_String); --- String_Output form is used if pragma Restrictions (No_String_Optimziations) +-- String_Output form is used if pragma Restrictions (No_String_Optimizations) -- is active, which requires element by element operations. The BLK_IO form -- is used if this restriction is not set, allowing block optimization. diff --git a/gcc/ada/libgnat/s-thread__ae653.adb b/gcc/ada/libgnat/s-thread__ae653.adb index bf9a563..fcf1304 100644 --- a/gcc/ada/libgnat/s-thread__ae653.adb +++ b/gcc/ada/libgnat/s-thread__ae653.adb @@ -36,6 +36,7 @@ pragma Restrictions (No_Tasking); -- which do not use Ada tasking. This restriction ensures that this -- will be checked by the binder. +with System.Storage_Elements; use System.Storage_Elements; with System.OS_Versions; use System.OS_Versions; package body System.Threads is @@ -44,14 +45,16 @@ package body System.Threads is package SSL renames System.Soft_Links; - Current_ATSD : aliased System.Address := System.Null_Address; - pragma Export (C, Current_ATSD, "__gnat_current_atsd"); - Main_ATSD : aliased ATSD; -- TSD for environment task - Stack_Limit : Address; + Current_ATSD : aliased System.Address := System.Null_Address; + pragma Thread_Local_Storage (Current_ATSD); + -- pragma TLS needed since TaskVarAdd no longer available + -- Assume guard pages for Helix APEX partitions, but leave + -- checking mechanism in for now, in case of surprises. ??? + Stack_Limit : Address; pragma Import (C, Stack_Limit, "__gnat_stack_limit"); type Set_Stack_Limit_Proc_Acc is access procedure; @@ -62,11 +65,10 @@ package body System.Threads is -- Procedure to be called when a task is created to set stack limit if -- limit checking is used. - -------------------------- - -- VxWorks specific API -- - -------------------------- + -- VxWorks specific API ERROR : constant STATUS := Interfaces.C.int (-1); + OK : constant STATUS := Interfaces.C.int (0); function taskIdVerify (tid : t_id) return STATUS; pragma Import (C, taskIdVerify, "taskIdVerify"); @@ -74,10 +76,6 @@ package body System.Threads is function taskIdSelf return t_id; pragma Import (C, taskIdSelf, "taskIdSelf"); - function taskVarAdd - (tid : t_id; pVar : System.Address) return int; - pragma Import (C, taskVarAdd, "taskVarAdd"); - ----------------------- -- Local Subprograms -- ----------------------- @@ -102,21 +100,18 @@ package body System.Threads is (Sec_Stack_Ptr : SST.SS_Stack_Ptr; Process_ATSD_Address : System.Address) is - -- Current_ATSD must already be a taskVar of taskIdSelf. - -- No assertion because taskVarGet is not available on VxWorks/CERT, - -- which is used on VxWorks 653 3.x as a guest OS. - TSD : constant ATSD_Access := From_Address (Process_ATSD_Address); + ATSD : constant ATSD_Access := From_Address (Process_ATSD_Address); begin - TSD.Sec_Stack_Ptr := Sec_Stack_Ptr; - SST.SS_Init (TSD.Sec_Stack_Ptr); + ATSD.Sec_Stack_Ptr := Sec_Stack_Ptr; + SST.SS_Init (ATSD.Sec_Stack_Ptr); Current_ATSD := Process_ATSD_Address; - Install_Handler; - -- Initialize stack limit if needed + -- Assume guard pages for Helix/Vx7, but leave in for now ??? + -- Initialize stack limit if needed. if Current_ATSD /= Main_ATSD'Address and then Set_Stack_Limit_Hook /= null @@ -184,24 +179,16 @@ package body System.Threads is -------------- function Register (T : Thread_Id) return STATUS is - Result : STATUS; - begin -- It cannot be assumed that the caller of this routine has a ATSD; -- so neither this procedure nor the procedures that it calls should -- raise or handle exceptions, or make use of a secondary stack. - -- This routine is only necessary because taskVarAdd cannot be - -- executed once an VxWorks 653 partition has entered normal mode - -- (depending on configRecord.c, allocation could be disabled). - -- Otherwise, everything could have been done in Thread_Body_Enter. - if taskIdVerify (T) = ERROR then return ERROR; end if; - Result := taskVarAdd (T, Current_ATSD'Address); - pragma Assert (Result /= ERROR); + Current_ATSD := To_Address (Integer_Address (T)); -- The same issue applies to the task variable that contains the stack -- limit when that overflow checking mechanism is used instead of @@ -211,17 +198,15 @@ package body System.Threads is -- System.Stack_Check_Limits = True. pragma Warnings (Off); + -- OS is a constant - if Result /= ERROR - and then OS /= VxWorks_653 - and then Set_Stack_Limit_Hook /= null - then - Result := taskVarAdd (T, Stack_Limit'Address); - pragma Assert (Result /= ERROR); + if OS /= VxWorks_653 and then Set_Stack_Limit_Hook /= null then + -- Check that this is correct if limit checking left in. ??? + Stack_Limit := To_Address (Integer_Address (T)); end if; pragma Warnings (On); - return Result; + return OK; end Register; ------------------- diff --git a/gcc/ada/libgnat/s-utf_32.adb b/gcc/ada/libgnat/s-utf_32.adb index a722d62..a1346f3 100644 --- a/gcc/ada/libgnat/s-utf_32.adb +++ b/gcc/ada/libgnat/s-utf_32.adb @@ -49,7 +49,7 @@ package body System.UTF_32 is ---------------------- -- Note these tables are derived from those given in AI-285. For details - -- see //www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00285.TXT?rev=1.22. + -- see www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00285.TXT?rev=1.22. type UTF_32_Range is record Lo : UTF_32; @@ -6071,9 +6071,6 @@ package body System.UTF_32 is 40, -- DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW 32); -- TAG LATIN CAPITAL LETTER A .. TAG LATIN CAPITAL LETTER Z - pragma Warnings (On); - -- Temporary until pragma Warnings at start can be activated ??? - -- The following is a list of the 10646 names for CAPITAL LETTER entries -- that have no matching SMALL LETTER entry and are thus not folded @@ -6117,6 +6114,403 @@ package body System.UTF_32 is -- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI -- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI + -- The following array includes all characters in the Unicode table with + -- the category NFKC_Quick_Check=No, taken from + -- www.unicode.org/Public/UCD/latest/ucd/DerivedNormalizationProps.txt + + UTF_32_NFKC_QC_No : constant UTF_32_Ranges := ( + (16#00A0#, 16#00A0#), -- NO-BREAK SPACE + (16#00A8#, 16#00A8#), -- DIAERESIS + (16#00AA#, 16#00AA#), -- FEMININE ORDINAL INDICATOR + (16#00AF#, 16#00AF#), -- MACRON + (16#00B2#, 16#00B3#), -- SUPERSCRIPT TWO..SUPERSCRIPT THREE + (16#00B4#, 16#00B4#), -- ACUTE ACCENT + (16#00B5#, 16#00B5#), -- MICRO SIGN + (16#00B8#, 16#00B8#), -- CEDILLA + (16#00B9#, 16#00B9#), -- SUPERSCRIPT ONE + (16#00BA#, 16#00BA#), -- MASCULINE ORDINAL INDICATOR + (16#00BC#, 16#00BE#), -- VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS + (16#0132#, 16#0133#), -- LATIN CAPITAL LIGATURE IJ..LATIN SMALL LIGATURE IJ + (16#013F#, 16#0140#), -- LATIN CAPITAL LETTER L WITH MIDDLE DOT..LATIN SMALL LETTER L WITH MIDDLE DOT + (16#0149#, 16#0149#), -- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE + (16#017F#, 16#017F#), -- LATIN SMALL LETTER LONG S + (16#01C4#, 16#01CC#), -- LATIN CAPITAL LETTER DZ WITH CARON..LATIN SMALL LETTER NJ + (16#01F1#, 16#01F3#), -- LATIN CAPITAL LETTER DZ..LATIN SMALL LETTER DZ + (16#02B0#, 16#02B8#), -- MODIFIER LETTER SMALL H..MODIFIER LETTER SMALL Y + (16#02D8#, 16#02DD#), -- BREVE..DOUBLE ACUTE ACCENT + (16#02E0#, 16#02E4#), -- MODIFIER LETTER SMALL GAMMA..MODIFIER LETTER SMALL REVERSED GLOTTAL STOP + (16#0340#, 16#0341#), -- COMBINING GRAVE TONE MARK..COMBINING ACUTE TONE MARK + (16#0343#, 16#0344#), -- COMBINING GREEK KORONIS..COMBINING GREEK DIALYTIKA TONOS + (16#0374#, 16#0374#), -- GREEK NUMERAL SIGN + (16#037A#, 16#037A#), -- GREEK YPOGEGRAMMENI + (16#037E#, 16#037E#), -- GREEK QUESTION MARK + (16#0384#, 16#0385#), -- GREEK TONOS..GREEK DIALYTIKA TONOS + (16#0387#, 16#0387#), -- GREEK ANO TELEIA + (16#03D0#, 16#03D6#), -- GREEK BETA SYMBOL..GREEK PI SYMBOL + (16#03F0#, 16#03F2#), -- GREEK KAPPA SYMBOL..GREEK LUNATE SIGMA SYMBOL + (16#03F4#, 16#03F5#), -- GREEK CAPITAL THETA SYMBOL..GREEK LUNATE EPSILON SYMBOL + (16#03F9#, 16#03F9#), -- GREEK CAPITAL LUNATE SIGMA SYMBOL + (16#0587#, 16#0587#), -- ARMENIAN SMALL LIGATURE ECH YIWN + (16#0675#, 16#0678#), -- ARABIC LETTER HIGH HAMZA ALEF..ARABIC LETTER HIGH HAMZA YEH + (16#0958#, 16#095F#), -- DEVANAGARI LETTER QA..DEVANAGARI LETTER YYA + (16#09DC#, 16#09DD#), -- BENGALI LETTER RRA..BENGALI LETTER RHA + (16#09DF#, 16#09DF#), -- BENGALI LETTER YYA + (16#0A33#, 16#0A33#), -- GURMUKHI LETTER LLA + (16#0A36#, 16#0A36#), -- GURMUKHI LETTER SHA + (16#0A59#, 16#0A5B#), -- GURMUKHI LETTER KHHA..GURMUKHI LETTER ZA + (16#0A5E#, 16#0A5E#), -- GURMUKHI LETTER FA + (16#0B5C#, 16#0B5D#), -- ORIYA LETTER RRA..ORIYA LETTER RHA + (16#0E33#, 16#0E33#), -- THAI CHARACTER SARA AM + (16#0EB3#, 16#0EB3#), -- LAO VOWEL SIGN AM + (16#0EDC#, 16#0EDD#), -- LAO HO NO..LAO HO MO + (16#0F0C#, 16#0F0C#), -- TIBETAN MARK DELIMITER TSHEG BSTAR + (16#0F43#, 16#0F43#), -- TIBETAN LETTER GHA + (16#0F4D#, 16#0F4D#), -- TIBETAN LETTER DDHA + (16#0F52#, 16#0F52#), -- TIBETAN LETTER DHA + (16#0F57#, 16#0F57#), -- TIBETAN LETTER BHA + (16#0F5C#, 16#0F5C#), -- TIBETAN LETTER DZHA + (16#0F69#, 16#0F69#), -- TIBETAN LETTER KSSA + (16#0F73#, 16#0F73#), -- TIBETAN VOWEL SIGN II + (16#0F75#, 16#0F79#), -- TIBETAN VOWEL SIGN UU..TIBETAN VOWEL SIGN VOCALIC LL + (16#0F81#, 16#0F81#), -- TIBETAN VOWEL SIGN REVERSED II + (16#0F93#, 16#0F93#), -- TIBETAN SUBJOINED LETTER GHA + (16#0F9D#, 16#0F9D#), -- TIBETAN SUBJOINED LETTER DDHA + (16#0FA2#, 16#0FA2#), -- TIBETAN SUBJOINED LETTER DHA + (16#0FA7#, 16#0FA7#), -- TIBETAN SUBJOINED LETTER BHA + (16#0FAC#, 16#0FAC#), -- TIBETAN SUBJOINED LETTER DZHA + (16#0FB9#, 16#0FB9#), -- TIBETAN SUBJOINED LETTER KSSA + (16#10FC#, 16#10FC#), -- MODIFIER LETTER GEORGIAN NAR + (16#1D2C#, 16#1D2E#), -- MODIFIER LETTER CAPITAL A..MODIFIER LETTER CAPITAL B + (16#1D30#, 16#1D3A#), -- MODIFIER LETTER CAPITAL D..MODIFIER LETTER CAPITAL N + (16#1D3C#, 16#1D4D#), -- MODIFIER LETTER CAPITAL O..MODIFIER LETTER SMALL G + (16#1D4F#, 16#1D6A#), -- MODIFIER LETTER SMALL K..GREEK SUBSCRIPT SMALL LETTER CHI + (16#1D78#, 16#1D78#), -- MODIFIER LETTER CYRILLIC EN + (16#1D9B#, 16#1DBF#), -- MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA + (16#1E9A#, 16#1E9B#), -- LATIN SMALL LETTER A WITH RIGHT HALF RING..LATIN SMALL LETTER LONG S WITH DOT ABOVE + (16#1F71#, 16#1F71#), -- GREEK SMALL LETTER ALPHA WITH OXIA + (16#1F73#, 16#1F73#), -- GREEK SMALL LETTER EPSILON WITH OXIA + (16#1F75#, 16#1F75#), -- GREEK SMALL LETTER ETA WITH OXIA + (16#1F77#, 16#1F77#), -- GREEK SMALL LETTER IOTA WITH OXIA + (16#1F79#, 16#1F79#), -- GREEK SMALL LETTER OMICRON WITH OXIA + (16#1F7B#, 16#1F7B#), -- GREEK SMALL LETTER UPSILON WITH OXIA + (16#1F7D#, 16#1F7D#), -- GREEK SMALL LETTER OMEGA WITH OXIA + (16#1FBB#, 16#1FBB#), -- GREEK CAPITAL LETTER ALPHA WITH OXIA + (16#1FBD#, 16#1FBD#), -- GREEK KORONIS + (16#1FBE#, 16#1FBE#), -- GREEK PROSGEGRAMMENI + (16#1FBF#, 16#1FC1#), -- GREEK PSILI..GREEK DIALYTIKA AND PERISPOMENI + (16#1FC9#, 16#1FC9#), -- GREEK CAPITAL LETTER EPSILON WITH OXIA + (16#1FCB#, 16#1FCB#), -- GREEK CAPITAL LETTER ETA WITH OXIA + (16#1FCD#, 16#1FCF#), -- GREEK PSILI AND VARIA..GREEK PSILI AND PERISPOMENI + (16#1FD3#, 16#1FD3#), -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA + (16#1FDB#, 16#1FDB#), -- GREEK CAPITAL LETTER IOTA WITH OXIA + (16#1FDD#, 16#1FDF#), -- GREEK DASIA AND VARIA..GREEK DASIA AND PERISPOMENI + (16#1FE3#, 16#1FE3#), -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA + (16#1FEB#, 16#1FEB#), -- GREEK CAPITAL LETTER UPSILON WITH OXIA + (16#1FED#, 16#1FEF#), -- GREEK DIALYTIKA AND VARIA..GREEK VARIA + (16#1FF9#, 16#1FF9#), -- GREEK CAPITAL LETTER OMICRON WITH OXIA + (16#1FFB#, 16#1FFB#), -- GREEK CAPITAL LETTER OMEGA WITH OXIA + (16#1FFD#, 16#1FFE#), -- GREEK OXIA..GREEK DASIA + (16#2000#, 16#200A#), -- EN QUAD..HAIR SPACE + (16#2011#, 16#2011#), -- NON-BREAKING HYPHEN + (16#2017#, 16#2017#), -- DOUBLE LOW LINE + (16#2024#, 16#2026#), -- ONE DOT LEADER..HORIZONTAL ELLIPSIS + (16#202F#, 16#202F#), -- NARROW NO-BREAK SPACE + (16#2033#, 16#2034#), -- DOUBLE PRIME..TRIPLE PRIME + (16#2036#, 16#2037#), -- REVERSED DOUBLE PRIME..REVERSED TRIPLE PRIME + (16#203C#, 16#203C#), -- DOUBLE EXCLAMATION MARK + (16#203E#, 16#203E#), -- OVERLINE + (16#2047#, 16#2049#), -- DOUBLE QUESTION MARK..EXCLAMATION QUESTION MARK + (16#2057#, 16#2057#), -- QUADRUPLE PRIME + (16#205F#, 16#205F#), -- MEDIUM MATHEMATICAL SPACE + (16#2070#, 16#2070#), -- SUPERSCRIPT ZERO + (16#2071#, 16#2071#), -- SUPERSCRIPT LATIN SMALL LETTER I + (16#2074#, 16#2079#), -- SUPERSCRIPT FOUR..SUPERSCRIPT NINE + (16#207A#, 16#207C#), -- SUPERSCRIPT PLUS SIGN..SUPERSCRIPT EQUALS SIGN + (16#207D#, 16#207D#), -- SUPERSCRIPT LEFT PARENTHESIS + (16#207E#, 16#207E#), -- SUPERSCRIPT RIGHT PARENTHESIS + (16#207F#, 16#207F#), -- SUPERSCRIPT LATIN SMALL LETTER N + (16#2080#, 16#2089#), -- SUBSCRIPT ZERO..SUBSCRIPT NINE + (16#208A#, 16#208C#), -- SUBSCRIPT PLUS SIGN..SUBSCRIPT EQUALS SIGN + (16#208D#, 16#208D#), -- SUBSCRIPT LEFT PARENTHESIS + (16#208E#, 16#208E#), -- SUBSCRIPT RIGHT PARENTHESIS + (16#2090#, 16#209C#), -- LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T + (16#20A8#, 16#20A8#), -- RUPEE SIGN + (16#2100#, 16#2101#), -- ACCOUNT OF..ADDRESSED TO THE SUBJECT + (16#2102#, 16#2102#), -- DOUBLE-STRUCK CAPITAL C + (16#2103#, 16#2103#), -- DEGREE CELSIUS + (16#2105#, 16#2106#), -- CARE OF..CADA UNA + (16#2107#, 16#2107#), -- EULER CONSTANT + (16#2109#, 16#2109#), -- DEGREE FAHRENHEIT + (16#210A#, 16#2113#), -- SCRIPT SMALL G..SCRIPT SMALL L + (16#2115#, 16#2115#), -- DOUBLE-STRUCK CAPITAL N + (16#2116#, 16#2116#), -- NUMERO SIGN + (16#2119#, 16#211D#), -- DOUBLE-STRUCK CAPITAL P..DOUBLE-STRUCK CAPITAL R + (16#2120#, 16#2122#), -- SERVICE MARK..TRADE MARK SIGN + (16#2124#, 16#2124#), -- DOUBLE-STRUCK CAPITAL Z + (16#2126#, 16#2126#), -- OHM SIGN + (16#2128#, 16#2128#), -- BLACK-LETTER CAPITAL Z + (16#212A#, 16#212D#), -- KELVIN SIGN..BLACK-LETTER CAPITAL C + (16#212F#, 16#2131#), -- SCRIPT SMALL E..SCRIPT CAPITAL F + (16#2133#, 16#2134#), -- SCRIPT CAPITAL M..SCRIPT SMALL O + (16#2135#, 16#2138#), -- ALEF SYMBOL..DALET SYMBOL + (16#2139#, 16#2139#), -- INFORMATION SOURCE + (16#213B#, 16#213B#), -- FACSIMILE SIGN + (16#213C#, 16#213F#), -- DOUBLE-STRUCK SMALL PI..DOUBLE-STRUCK CAPITAL PI + (16#2140#, 16#2140#), -- DOUBLE-STRUCK N-ARY SUMMATION + (16#2145#, 16#2149#), -- DOUBLE-STRUCK ITALIC CAPITAL D..DOUBLE-STRUCK ITALIC SMALL J + (16#2150#, 16#215F#), -- VULGAR FRACTION ONE SEVENTH..FRACTION NUMERATOR ONE + (16#2160#, 16#217F#), -- ROMAN NUMERAL ONE..SMALL ROMAN NUMERAL ONE THOUSAND + (16#2189#, 16#2189#), -- VULGAR FRACTION ZERO THIRDS + (16#222C#, 16#222D#), -- DOUBLE INTEGRAL..TRIPLE INTEGRAL + (16#222F#, 16#2230#), -- SURFACE INTEGRAL..VOLUME INTEGRAL + (16#2329#, 16#2329#), -- LEFT-POINTING ANGLE BRACKET + (16#232A#, 16#232A#), -- RIGHT-POINTING ANGLE BRACKET + (16#2460#, 16#249B#), -- CIRCLED DIGIT ONE..NUMBER TWENTY FULL STOP + (16#249C#, 16#24E9#), -- PARENTHESIZED LATIN SMALL LETTER A..CIRCLED LATIN SMALL LETTER Z + (16#24EA#, 16#24EA#), -- CIRCLED DIGIT ZERO + (16#2A0C#, 16#2A0C#), -- QUADRUPLE INTEGRAL OPERATOR + (16#2A74#, 16#2A76#), -- DOUBLE COLON EQUAL..THREE CONSECUTIVE EQUALS SIGNS + (16#2ADC#, 16#2ADC#), -- FORKING + (16#2C7C#, 16#2C7D#), -- LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V + (16#2D6F#, 16#2D6F#), -- TIFINAGH MODIFIER LETTER LABIALIZATION MARK + (16#2E9F#, 16#2E9F#), -- CJK RADICAL MOTHER + (16#2EF3#, 16#2EF3#), -- CJK RADICAL C-SIMPLIFIED TURTLE + (16#2F00#, 16#2FD5#), -- KANGXI RADICAL ONE..KANGXI RADICAL FLUTE + (16#3000#, 16#3000#), -- IDEOGRAPHIC SPACE + (16#3036#, 16#3036#), -- CIRCLED POSTAL MARK + (16#3038#, 16#303A#), -- HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY + (16#309B#, 16#309C#), -- KATAKANA-HIRAGANA VOICED SOUND MARK..KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK + (16#309F#, 16#309F#), -- HIRAGANA DIGRAPH YORI + (16#30FF#, 16#30FF#), -- KATAKANA DIGRAPH KOTO + (16#3131#, 16#318E#), -- HANGUL LETTER KIYEOK..HANGUL LETTER ARAEAE + (16#3192#, 16#3195#), -- IDEOGRAPHIC ANNOTATION ONE MARK..IDEOGRAPHIC ANNOTATION FOUR MARK + (16#3196#, 16#319F#), -- IDEOGRAPHIC ANNOTATION TOP MARK..IDEOGRAPHIC ANNOTATION MAN MARK + (16#3200#, 16#321E#), -- PARENTHESIZED HANGUL KIYEOK..PARENTHESIZED KOREAN CHARACTER O HU + (16#3220#, 16#3229#), -- PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN + (16#322A#, 16#3247#), -- PARENTHESIZED IDEOGRAPH MOON..CIRCLED IDEOGRAPH KOTO + (16#3250#, 16#3250#), -- PARTNERSHIP SIGN + (16#3251#, 16#325F#), -- CIRCLED NUMBER TWENTY ONE..CIRCLED NUMBER THIRTY FIVE + (16#3260#, 16#327E#), -- CIRCLED HANGUL KIYEOK..CIRCLED HANGUL IEUNG U + (16#3280#, 16#3289#), -- CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN + (16#328A#, 16#32B0#), -- CIRCLED IDEOGRAPH MOON..CIRCLED IDEOGRAPH NIGHT + (16#32B1#, 16#32BF#), -- CIRCLED NUMBER THIRTY SIX..CIRCLED NUMBER FIFTY + (16#32C0#, 16#33FF#), -- IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY..SQUARE GAL + (16#A69C#, 16#A69D#), -- MODIFIER LETTER CYRILLIC HARD SIGN..MODIFIER LETTER CYRILLIC SOFT SIGN + (16#A770#, 16#A770#), -- MODIFIER LETTER US + (16#A7F8#, 16#A7F9#), -- MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE + (16#AB5C#, 16#AB5F#), -- MODIFIER LETTER SMALL HENG..MODIFIER LETTER SMALL U WITH LEFT HOOK + (16#AB69#, 16#AB69#), -- MODIFIER LETTER SMALL TURNED W + (16#F900#, 16#FA0D#), -- CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA0D + (16#FA10#, 16#FA10#), -- CJK COMPATIBILITY IDEOGRAPH-FA10 + (16#FA12#, 16#FA12#), -- CJK COMPATIBILITY IDEOGRAPH-FA12 + (16#FA15#, 16#FA1E#), -- CJK COMPATIBILITY IDEOGRAPH-FA15..CJK COMPATIBILITY IDEOGRAPH-FA1E + (16#FA20#, 16#FA20#), -- CJK COMPATIBILITY IDEOGRAPH-FA20 + (16#FA22#, 16#FA22#), -- CJK COMPATIBILITY IDEOGRAPH-FA22 + (16#FA25#, 16#FA26#), -- CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26 + (16#FA2A#, 16#FA6D#), -- CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D + (16#FA70#, 16#FAD9#), -- CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9 + (16#FB00#, 16#FB06#), -- LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST + (16#FB13#, 16#FB17#), -- ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH + (16#FB1D#, 16#FB1D#), -- HEBREW LETTER YOD WITH HIRIQ + (16#FB1F#, 16#FB28#), -- HEBREW LIGATURE YIDDISH YOD YOD PATAH..HEBREW LETTER WIDE TAV + (16#FB29#, 16#FB29#), -- HEBREW LETTER ALTERNATIVE PLUS SIGN + (16#FB2A#, 16#FB36#), -- HEBREW LETTER SHIN WITH SHIN DOT..HEBREW LETTER ZAYIN WITH DAGESH + (16#FB38#, 16#FB3C#), -- HEBREW LETTER TET WITH DAGESH..HEBREW LETTER LAMED WITH DAGESH + (16#FB3E#, 16#FB3E#), -- HEBREW LETTER MEM WITH DAGESH + (16#FB40#, 16#FB41#), -- HEBREW LETTER NUN WITH DAGESH..HEBREW LETTER SAMEKH WITH DAGESH + (16#FB43#, 16#FB44#), -- HEBREW LETTER FINAL PE WITH DAGESH..HEBREW LETTER PE WITH DAGESH + (16#FB46#, 16#FBB1#), -- HEBREW LETTER TSADI WITH DAGESH..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM + (16#FBD3#, 16#FD3D#), -- ARABIC LETTER NG ISOLATED FORM..ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM + (16#FD50#, 16#FD8F#), -- ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM..ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM + (16#FD92#, 16#FDC7#), -- ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM..ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM + (16#FDF0#, 16#FDFB#), -- ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM..ARABIC LIGATURE JALLAJALALOUHOU + (16#FDFC#, 16#FDFC#), -- RIAL SIGN + (16#FE10#, 16#FE16#), -- PRESENTATION FORM FOR VERTICAL COMMA..PRESENTATION FORM FOR VERTICAL QUESTION MARK + (16#FE17#, 16#FE17#), -- PRESENTATION FORM FOR VERTICAL LEFT WHITE LENTICULAR BRACKET + (16#FE18#, 16#FE18#), -- PRESENTATION FORM FOR VERTICAL RIGHT WHITE LENTICULAR BRAKCET + (16#FE19#, 16#FE19#), -- PRESENTATION FORM FOR VERTICAL HORIZONTAL ELLIPSIS + (16#FE30#, 16#FE30#), -- PRESENTATION FORM FOR VERTICAL TWO DOT LEADER + (16#FE31#, 16#FE32#), -- PRESENTATION FORM FOR VERTICAL EM DASH..PRESENTATION FORM FOR VERTICAL EN DASH + (16#FE33#, 16#FE34#), -- PRESENTATION FORM FOR VERTICAL LOW LINE..PRESENTATION FORM FOR VERTICAL WAVY LOW LINE + (16#FE35#, 16#FE35#), -- PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS + (16#FE36#, 16#FE36#), -- PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS + (16#FE37#, 16#FE37#), -- PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET + (16#FE38#, 16#FE38#), -- PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET + (16#FE39#, 16#FE39#), -- PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET + (16#FE3A#, 16#FE3A#), -- PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET + (16#FE3B#, 16#FE3B#), -- PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET + (16#FE3C#, 16#FE3C#), -- PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET + (16#FE3D#, 16#FE3D#), -- PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET + (16#FE3E#, 16#FE3E#), -- PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET + (16#FE3F#, 16#FE3F#), -- PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET + (16#FE40#, 16#FE40#), -- PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET + (16#FE41#, 16#FE41#), -- PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET + (16#FE42#, 16#FE42#), -- PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET + (16#FE43#, 16#FE43#), -- PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET + (16#FE44#, 16#FE44#), -- PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET + (16#FE47#, 16#FE47#), -- PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET + (16#FE48#, 16#FE48#), -- PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET + (16#FE49#, 16#FE4C#), -- DASHED OVERLINE..DOUBLE WAVY OVERLINE + (16#FE4D#, 16#FE4F#), -- DASHED LOW LINE..WAVY LOW LINE + (16#FE50#, 16#FE52#), -- SMALL COMMA..SMALL FULL STOP + (16#FE54#, 16#FE57#), -- SMALL SEMICOLON..SMALL EXCLAMATION MARK + (16#FE58#, 16#FE58#), -- SMALL EM DASH + (16#FE59#, 16#FE59#), -- SMALL LEFT PARENTHESIS + (16#FE5A#, 16#FE5A#), -- SMALL RIGHT PARENTHESIS + (16#FE5B#, 16#FE5B#), -- SMALL LEFT CURLY BRACKET + (16#FE5C#, 16#FE5C#), -- SMALL RIGHT CURLY BRACKET + (16#FE5D#, 16#FE5D#), -- SMALL LEFT TORTOISE SHELL BRACKET + (16#FE5E#, 16#FE5E#), -- SMALL RIGHT TORTOISE SHELL BRACKET + (16#FE5F#, 16#FE61#), -- SMALL NUMBER SIGN..SMALL ASTERISK + (16#FE62#, 16#FE62#), -- SMALL PLUS SIGN + (16#FE63#, 16#FE63#), -- SMALL HYPHEN-MINUS + (16#FE64#, 16#FE66#), -- SMALL LESS-THAN SIGN..SMALL EQUALS SIGN + (16#FE68#, 16#FE68#), -- SMALL REVERSE SOLIDUS + (16#FE69#, 16#FE69#), -- SMALL DOLLAR SIGN + (16#FE6A#, 16#FE6B#), -- SMALL PERCENT SIGN..SMALL COMMERCIAL AT + (16#FE70#, 16#FE72#), -- ARABIC FATHATAN ISOLATED FORM..ARABIC DAMMATAN ISOLATED FORM + (16#FE74#, 16#FE74#), -- ARABIC KASRATAN ISOLATED FORM + (16#FE76#, 16#FEFC#), -- ARABIC FATHA ISOLATED FORM..ARABIC LIGATURE LAM WITH ALEF FINAL FORM + (16#FF01#, 16#FF03#), -- FULLWIDTH EXCLAMATION MARK..FULLWIDTH NUMBER SIGN + (16#FF04#, 16#FF04#), -- FULLWIDTH DOLLAR SIGN + (16#FF05#, 16#FF07#), -- FULLWIDTH PERCENT SIGN..FULLWIDTH APOSTROPHE + (16#FF08#, 16#FF08#), -- FULLWIDTH LEFT PARENTHESIS + (16#FF09#, 16#FF09#), -- FULLWIDTH RIGHT PARENTHESIS + (16#FF0A#, 16#FF0A#), -- FULLWIDTH ASTERISK + (16#FF0B#, 16#FF0B#), -- FULLWIDTH PLUS SIGN + (16#FF0C#, 16#FF0C#), -- FULLWIDTH COMMA + (16#FF0D#, 16#FF0D#), -- FULLWIDTH HYPHEN-MINUS + (16#FF0E#, 16#FF0F#), -- FULLWIDTH FULL STOP..FULLWIDTH SOLIDUS + (16#FF10#, 16#FF19#), -- FULLWIDTH DIGIT ZERO..FULLWIDTH DIGIT NINE + (16#FF1A#, 16#FF1B#), -- FULLWIDTH COLON..FULLWIDTH SEMICOLON + (16#FF1C#, 16#FF1E#), -- FULLWIDTH LESS-THAN SIGN..FULLWIDTH GREATER-THAN SIGN + (16#FF1F#, 16#FF20#), -- FULLWIDTH QUESTION MARK..FULLWIDTH COMMERCIAL AT + (16#FF21#, 16#FF3A#), -- FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z + (16#FF3B#, 16#FF3B#), -- FULLWIDTH LEFT SQUARE BRACKET + (16#FF3C#, 16#FF3C#), -- FULLWIDTH REVERSE SOLIDUS + (16#FF3D#, 16#FF3D#), -- FULLWIDTH RIGHT SQUARE BRACKET + (16#FF3E#, 16#FF3E#), -- FULLWIDTH CIRCUMFLEX ACCENT + (16#FF3F#, 16#FF3F#), -- FULLWIDTH LOW LINE + (16#FF40#, 16#FF40#), -- FULLWIDTH GRAVE ACCENT + (16#FF41#, 16#FF5A#), -- FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH LATIN SMALL LETTER Z + (16#FF5B#, 16#FF5B#), -- FULLWIDTH LEFT CURLY BRACKET + (16#FF5C#, 16#FF5C#), -- FULLWIDTH VERTICAL LINE + (16#FF5D#, 16#FF5D#), -- FULLWIDTH RIGHT CURLY BRACKET + (16#FF5E#, 16#FF5E#), -- FULLWIDTH TILDE + (16#FF5F#, 16#FF5F#), -- FULLWIDTH LEFT WHITE PARENTHESIS + (16#FF60#, 16#FF60#), -- FULLWIDTH RIGHT WHITE PARENTHESIS + (16#FF61#, 16#FF61#), -- HALFWIDTH IDEOGRAPHIC FULL STOP + (16#FF62#, 16#FF62#), -- HALFWIDTH LEFT CORNER BRACKET + (16#FF63#, 16#FF63#), -- HALFWIDTH RIGHT CORNER BRACKET + (16#FF64#, 16#FF65#), -- HALFWIDTH IDEOGRAPHIC COMMA..HALFWIDTH KATAKANA MIDDLE DOT + (16#FF66#, 16#FF6F#), -- HALFWIDTH KATAKANA LETTER WO..HALFWIDTH KATAKANA LETTER SMALL TU + (16#FF70#, 16#FF70#), -- HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK + (16#FF71#, 16#FF9D#), -- HALFWIDTH KATAKANA LETTER A..HALFWIDTH KATAKANA LETTER N + (16#FF9E#, 16#FF9F#), -- HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK + (16#FFA0#, 16#FFBE#), -- HALFWIDTH HANGUL FILLER..HALFWIDTH HANGUL LETTER HIEUH + (16#FFC2#, 16#FFC7#), -- HALFWIDTH HANGUL LETTER A..HALFWIDTH HANGUL LETTER E + (16#FFCA#, 16#FFCF#), -- HALFWIDTH HANGUL LETTER YEO..HALFWIDTH HANGUL LETTER OE + (16#FFD2#, 16#FFD7#), -- HALFWIDTH HANGUL LETTER YO..HALFWIDTH HANGUL LETTER YU + (16#FFDA#, 16#FFDC#), -- HALFWIDTH HANGUL LETTER EU..HALFWIDTH HANGUL LETTER I + (16#FFE0#, 16#FFE1#), -- FULLWIDTH CENT SIGN..FULLWIDTH POUND SIGN + (16#FFE2#, 16#FFE2#), -- FULLWIDTH NOT SIGN + (16#FFE3#, 16#FFE3#), -- FULLWIDTH MACRON + (16#FFE4#, 16#FFE4#), -- FULLWIDTH BROKEN BAR + (16#FFE5#, 16#FFE6#), -- FULLWIDTH YEN SIGN..FULLWIDTH WON SIGN + (16#FFE8#, 16#FFE8#), -- HALFWIDTH FORMS LIGHT VERTICAL + (16#FFE9#, 16#FFEC#), -- HALFWIDTH LEFTWARDS ARROW..HALFWIDTH DOWNWARDS ARROW + (16#FFED#, 16#FFEE#), -- HALFWIDTH BLACK SQUARE..HALFWIDTH WHITE CIRCLE + (16#1D15E#, 16#1D164#), -- MUSICAL SYMBOL HALF NOTE..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE + (16#1D1BB#, 16#1D1C0#), -- MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK + (16#1D400#, 16#1D454#), -- MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL ITALIC SMALL G + (16#1D456#, 16#1D49C#), -- MATHEMATICAL ITALIC SMALL I..MATHEMATICAL SCRIPT CAPITAL A + (16#1D49E#, 16#1D49F#), -- MATHEMATICAL SCRIPT CAPITAL C..MATHEMATICAL SCRIPT CAPITAL D + (16#1D4A2#, 16#1D4A2#), -- MATHEMATICAL SCRIPT CAPITAL G + (16#1D4A5#, 16#1D4A6#), -- MATHEMATICAL SCRIPT CAPITAL J..MATHEMATICAL SCRIPT CAPITAL K + (16#1D4A9#, 16#1D4AC#), -- MATHEMATICAL SCRIPT CAPITAL N..MATHEMATICAL SCRIPT CAPITAL Q + (16#1D4AE#, 16#1D4B9#), -- MATHEMATICAL SCRIPT CAPITAL S..MATHEMATICAL SCRIPT SMALL D + (16#1D4BB#, 16#1D4BB#), -- MATHEMATICAL SCRIPT SMALL F + (16#1D4BD#, 16#1D4C3#), -- MATHEMATICAL SCRIPT SMALL H..MATHEMATICAL SCRIPT SMALL N + (16#1D4C5#, 16#1D505#), -- MATHEMATICAL SCRIPT SMALL P..MATHEMATICAL FRAKTUR CAPITAL B + (16#1D507#, 16#1D50A#), -- MATHEMATICAL FRAKTUR CAPITAL D..MATHEMATICAL FRAKTUR CAPITAL G + (16#1D50D#, 16#1D514#), -- MATHEMATICAL FRAKTUR CAPITAL J..MATHEMATICAL FRAKTUR CAPITAL Q + (16#1D516#, 16#1D51C#), -- MATHEMATICAL FRAKTUR CAPITAL S..MATHEMATICAL FRAKTUR CAPITAL Y + (16#1D51E#, 16#1D539#), -- MATHEMATICAL FRAKTUR SMALL A..MATHEMATICAL DOUBLE-STRUCK CAPITAL B + (16#1D53B#, 16#1D53E#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL D..MATHEMATICAL DOUBLE-STRUCK CAPITAL G + (16#1D540#, 16#1D544#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL I..MATHEMATICAL DOUBLE-STRUCK CAPITAL M + (16#1D546#, 16#1D546#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL O + (16#1D54A#, 16#1D550#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL S..MATHEMATICAL DOUBLE-STRUCK CAPITAL Y + (16#1D552#, 16#1D6A5#), -- MATHEMATICAL DOUBLE-STRUCK SMALL A..MATHEMATICAL ITALIC SMALL DOTLESS J + (16#1D6A8#, 16#1D6C0#), -- MATHEMATICAL BOLD CAPITAL ALPHA..MATHEMATICAL BOLD CAPITAL OMEGA + (16#1D6C1#, 16#1D6C1#), -- MATHEMATICAL BOLD NABLA + (16#1D6C2#, 16#1D6DA#), -- MATHEMATICAL BOLD SMALL ALPHA..MATHEMATICAL BOLD SMALL OMEGA + (16#1D6DB#, 16#1D6DB#), -- MATHEMATICAL BOLD PARTIAL DIFFERENTIAL + (16#1D6DC#, 16#1D6FA#), -- MATHEMATICAL BOLD EPSILON SYMBOL..MATHEMATICAL ITALIC CAPITAL OMEGA + (16#1D6FB#, 16#1D6FB#), -- MATHEMATICAL ITALIC NABLA + (16#1D6FC#, 16#1D714#), -- MATHEMATICAL ITALIC SMALL ALPHA..MATHEMATICAL ITALIC SMALL OMEGA + (16#1D715#, 16#1D715#), -- MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL + (16#1D716#, 16#1D734#), -- MATHEMATICAL ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD ITALIC CAPITAL OMEGA + (16#1D735#, 16#1D735#), -- MATHEMATICAL BOLD ITALIC NABLA + (16#1D736#, 16#1D74E#), -- MATHEMATICAL BOLD ITALIC SMALL ALPHA..MATHEMATICAL BOLD ITALIC SMALL OMEGA + (16#1D74F#, 16#1D74F#), -- MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL + (16#1D750#, 16#1D76E#), -- MATHEMATICAL BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA + (16#1D76F#, 16#1D76F#), -- MATHEMATICAL SANS-SERIF BOLD NABLA + (16#1D770#, 16#1D788#), -- MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA + (16#1D789#, 16#1D789#), -- MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL + (16#1D78A#, 16#1D7A8#), -- MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA + (16#1D7A9#, 16#1D7A9#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA + (16#1D7AA#, 16#1D7C2#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA + (16#1D7C3#, 16#1D7C3#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL + (16#1D7C4#, 16#1D7CB#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA + (16#1D7CE#, 16#1D7FF#), -- MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE + (16#1EE00#, 16#1EE03#), -- ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL + (16#1EE05#, 16#1EE1F#), -- ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF + (16#1EE21#, 16#1EE22#), -- ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM + (16#1EE24#, 16#1EE24#), -- ARABIC MATHEMATICAL INITIAL HEH + (16#1EE27#, 16#1EE27#), -- ARABIC MATHEMATICAL INITIAL HAH + (16#1EE29#, 16#1EE32#), -- ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF + (16#1EE34#, 16#1EE37#), -- ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH + (16#1EE39#, 16#1EE39#), -- ARABIC MATHEMATICAL INITIAL DAD + (16#1EE3B#, 16#1EE3B#), -- ARABIC MATHEMATICAL INITIAL GHAIN + (16#1EE42#, 16#1EE42#), -- ARABIC MATHEMATICAL TAILED JEEM + (16#1EE47#, 16#1EE47#), -- ARABIC MATHEMATICAL TAILED HAH + (16#1EE49#, 16#1EE49#), -- ARABIC MATHEMATICAL TAILED YEH + (16#1EE4B#, 16#1EE4B#), -- ARABIC MATHEMATICAL TAILED LAM + (16#1EE4D#, 16#1EE4F#), -- ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN + (16#1EE51#, 16#1EE52#), -- ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF + (16#1EE54#, 16#1EE54#), -- ARABIC MATHEMATICAL TAILED SHEEN + (16#1EE57#, 16#1EE57#), -- ARABIC MATHEMATICAL TAILED KHAH + (16#1EE59#, 16#1EE59#), -- ARABIC MATHEMATICAL TAILED DAD + (16#1EE5B#, 16#1EE5B#), -- ARABIC MATHEMATICAL TAILED GHAIN + (16#1EE5D#, 16#1EE5D#), -- ARABIC MATHEMATICAL TAILED DOTLESS NOON + (16#1EE5F#, 16#1EE5F#), -- ARABIC MATHEMATICAL TAILED DOTLESS QAF + (16#1EE61#, 16#1EE62#), -- ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM + (16#1EE64#, 16#1EE64#), -- ARABIC MATHEMATICAL STRETCHED HEH + (16#1EE67#, 16#1EE6A#), -- ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF + (16#1EE6C#, 16#1EE72#), -- ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF + (16#1EE74#, 16#1EE77#), -- ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH + (16#1EE79#, 16#1EE7C#), -- ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH + (16#1EE7E#, 16#1EE7E#), -- ARABIC MATHEMATICAL STRETCHED DOTLESS FEH + (16#1EE80#, 16#1EE89#), -- ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH + (16#1EE8B#, 16#1EE9B#), -- ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN + (16#1EEA1#, 16#1EEA3#), -- ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL + (16#1EEA5#, 16#1EEA9#), -- ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH + (16#1EEAB#, 16#1EEBB#), -- ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN + (16#1F100#, 16#1F10A#), -- DIGIT ZERO FULL STOP..DIGIT NINE COMMA + (16#1F110#, 16#1F12E#), -- PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ + (16#1F130#, 16#1F14F#), -- SQUARED LATIN CAPITAL LETTER A..SQUARED WC + (16#1F16A#, 16#1F16C#), -- RAISED MC SIGN..RAISED MR SIGN + (16#1F190#, 16#1F190#), -- SQUARE DJ + (16#1F200#, 16#1F202#), -- SQUARE HIRAGANA HOKA..SQUARED KATAKANA SA + (16#1F210#, 16#1F23B#), -- SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-914D + (16#1F240#, 16#1F248#), -- TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-672C..TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-6557 + (16#1F250#, 16#1F251#), -- CIRCLED IDEOGRAPH ADVANTAGE..CIRCLED IDEOGRAPH ACCEPT + (16#1FBF0#, 16#1FBF9#), -- SEGMENTED DIGIT ZERO..SEGMENTED DIGIT NINE + (16#2F800#, 16#2FA1D#)); -- CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D + + pragma Warnings (On); + -- Temporary until pragma Warnings at start can be activated ??? + type Decomposition_Mapping is record Item : UTF_32; First_Char_Mapping : UTF_32; @@ -12001,6 +12395,15 @@ package body System.UTF_32 is return Non_Graphic (C); end Is_UTF_32_Non_Graphic; + -------------------- + -- Is_UTF_32_NFKC -- + -------------------- + + function Is_UTF_32_NFKC (U : UTF_32) return Boolean is + begin + return U < 160 or else Range_Search (U, UTF_32_NFKC_QC_No) = 0; + end Is_UTF_32_NFKC; + --------------------- -- Is_UTF_32_Other -- --------------------- diff --git a/gcc/ada/libgnat/s-utf_32.ads b/gcc/ada/libgnat/s-utf_32.ads index b8e4e3e..e3f0e00 100644 --- a/gcc/ada/libgnat/s-utf_32.ads +++ b/gcc/ada/libgnat/s-utf_32.ads @@ -189,6 +189,12 @@ package System.UTF_32 is -- letters to upper case using this routine. A corresponding routine to -- fold to lower case is also provided. + function Is_UTF_32_NFKC (U : UTF_32) return Boolean; + pragma Inline (Is_UTF_32_NFKC); + -- Return True if U could be present in a string normalized to + -- Normalization Form KC (as defined by Clause 21 of ISO/IEC 10646:2017), + -- otherwise returns False. + function Is_UTF_32_Basic (U : UTF_32) return Boolean; pragma Inline (Is_UTF_32_Basic); -- Return True if U has no Decomposition Mapping in the code charts of diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 6cc05bb..e39e0b9 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -1265,230 +1265,6 @@ package body Namet is return Name_Find (Buf); end Name_Find; - ------------- - -- Nam_In -- - ------------- - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id; - V9 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id; - V9 : Name_Id; - V10 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9 or else - T = V10; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id; - V9 : Name_Id; - V10 : Name_Id; - V11 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9 or else - T = V10 or else - T = V11; - end Nam_In; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id; - V9 : Name_Id; - V10 : Name_Id; - V11 : Name_Id; - V12 : Name_Id) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9 or else - T = V10 or else - T = V11 or else - T = V12; - end Nam_In; - ----------------- -- Name_Equals -- ----------------- diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 670cdc9..ce7cac1 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -207,130 +207,6 @@ package Namet is pragma Inline (Present); -- Determine whether name Nam exists - ------------------------------ - -- Name_Id Membership Tests -- - ------------------------------ - - -- The following functions allow a convenient notation for testing whether - -- a Name_Id value matches any one of a list of possible values. In each - -- case True is returned if the given T argument is equal to any of the V - -- arguments. These essentially duplicate the Ada 2012 membership tests, - -- but we cannot use the latter (yet) in the compiler front end, because - -- of bootstrap considerations - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id; - V9 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id; - V9 : Name_Id; - V10 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id; - V9 : Name_Id; - V10 : Name_Id; - V11 : Name_Id) return Boolean; - - function Nam_In - (T : Name_Id; - V1 : Name_Id; - V2 : Name_Id; - V3 : Name_Id; - V4 : Name_Id; - V5 : Name_Id; - V6 : Name_Id; - V7 : Name_Id; - V8 : Name_Id; - V9 : Name_Id; - V10 : Name_Id; - V11 : Name_Id; - V12 : Name_Id) return Boolean; - - pragma Inline (Nam_In); - -- Inline all above functions - ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 874d144..29eec04 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -991,7 +991,7 @@ package body Nlists is N := Node; loop Next (N); - exit when not Nkind_In (N, N_Pragma, N_Null_Statement); + exit when Nkind (N) not in N_Pragma | N_Null_Statement; end loop; return N; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 37f3d03..885a6fb 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -114,7 +114,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_2012; + Ada_Version_Runtime : Ada_Version_Type := Ada_2020; -- GNAT -- Ada version used to compile the runtime. Used to set Ada_Version (but -- not Ada_Version_Explicit) when compiling predefined or internal units. @@ -525,6 +525,13 @@ package Opt is -- dataflow analysis, which is not available. This behavior parallels that -- of the old ABE mechanism. + Enable_128bit_Types : Boolean := False; + -- GNAT + -- Set to True to enable the support for 128-bit types in the compiler. + -- The prerequisite is a 64-bit target that supports 128-bit computation. + + -- WARNING: There is a matching C declaration of this variable in fe.h + Error_Msg_Line_Length : Nat := 0; -- GNAT -- Records the error message line length limit. If this is set to zero, @@ -620,7 +627,7 @@ package Opt is Extensions_Allowed : Boolean := False; -- GNAT -- Set to True by switch -gnatX if GNAT specific language extensions - -- are allowed. Currently there are no such defined 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 diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index d36aac8..971819b 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -45,6 +45,13 @@ package body Output is Current_FD : File_Descriptor := Standout; -- File descriptor for current output + type FD_Array is array (Nat range 1 .. 3) of File_Descriptor; + FD_Stack : FD_Array; + FD_Stack_Idx : Nat := FD_Array'First - 1; + -- Maintain a small stack for Push_Output and Pop_Output. We'd normally + -- use Table for this and allow an unlimited depth, but we're the target + -- of a pragma Elaborate_All in Table, so we can't use it here. + Special_Output_Proc : Output_Proc := null; -- Record argument to last call to Set_Special_Output. If this is -- non-null, then we are in special output mode. @@ -228,6 +235,28 @@ package body Output is (Cur_Indentation - Indentation_Amount) mod Indentation_Limit; end Outdent; + ---------------- + -- Pop_Output -- + ---------------- + + procedure Pop_Output is + begin + pragma Assert (FD_Stack_Idx >= FD_Array'First); + Current_FD := FD_Stack (FD_Stack_Idx); + FD_Stack_Idx := FD_Stack_Idx - 1; + end Pop_Output; + + ----------------- + -- Push_Output -- + ----------------- + + procedure Push_Output is + begin + pragma Assert (FD_Stack_Idx < FD_Array'Last); + FD_Stack_Idx := FD_Stack_Idx + 1; + FD_Stack (FD_Stack_Idx) := Current_FD; + end Push_Output; + --------------------------- -- Restore_Output_Buffer -- --------------------------- diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 4574cce..55d308a 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -95,6 +95,15 @@ package Output is -- output will appear on the given file descriptor only after special -- output has been cancelled. + procedure Push_Output; + -- Saves the current output destination on a stack, but leaves it + -- unchanged. This subprogram only supports a small stack and is normally + -- used with a depth of one. + + procedure Pop_Output; + -- Changes the current output destination to be the last output destination + -- popped using Push_Output. + procedure Indent; -- Increases the current indentation level. Whenever a line is written -- (triggered by Eol), an appropriate amount of whitespace is added to the diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index f8b3f33..e4298e8 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -511,7 +511,7 @@ package body Ch10 is -- Another error from which it is hard to recover - if Nkind_In (Unit_Node, N_Subprogram_Body_Stub, N_Package_Body_Stub) then + if Nkind (Unit_Node) in N_Subprogram_Body_Stub | N_Package_Body_Stub then Cunit_Error_Flag := True; return Error; end if; @@ -527,10 +527,10 @@ package body Ch10 is Unit_Node := Specification (Unit_Node); end if; - if Nkind_In (Unit_Node, N_Package_Declaration, - N_Subprogram_Declaration, - N_Subprogram_Body, - N_Subprogram_Renaming_Declaration) + if Nkind (Unit_Node) in N_Package_Declaration + | N_Subprogram_Declaration + | N_Subprogram_Body + | N_Subprogram_Renaming_Declaration then Unit_Node := Specification (Unit_Node); @@ -541,27 +541,26 @@ package body Ch10 is end if; end if; - if Nkind_In (Unit_Node, N_Task_Body, - N_Protected_Body, - N_Task_Type_Declaration, - N_Protected_Type_Declaration, - N_Single_Task_Declaration, - N_Single_Protected_Declaration) + if Nkind (Unit_Node) in N_Task_Body + | N_Protected_Body + | N_Task_Type_Declaration + | N_Protected_Type_Declaration + | N_Single_Task_Declaration + | N_Single_Protected_Declaration then Name_Node := Defining_Identifier (Unit_Node); - elsif Nkind_In (Unit_Node, N_Function_Instantiation, - N_Function_Specification, - N_Generic_Function_Renaming_Declaration, - N_Generic_Package_Renaming_Declaration, - N_Generic_Procedure_Renaming_Declaration) - or else - Nkind_In (Unit_Node, N_Package_Body, - N_Package_Instantiation, - N_Package_Renaming_Declaration, - N_Package_Specification, - N_Procedure_Instantiation, - N_Procedure_Specification) + elsif Nkind (Unit_Node) in N_Function_Instantiation + | N_Function_Specification + | N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + or else Nkind (Unit_Node) in N_Package_Body + | N_Package_Instantiation + | N_Package_Renaming_Declaration + | N_Package_Specification + | N_Procedure_Instantiation + | N_Procedure_Specification then Name_Node := Defining_Unit_Name (Unit_Node); diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 6bdd5d9..78febbf 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -324,8 +324,7 @@ package body Ch2 is (Identifier_Seen => Identifier_Seen, Association => Assoc_Node, Reserved_Words_OK => - Nam_In (Prag_Name, Name_Restriction_Warnings, - Name_Restrictions)); + Prag_Name in Name_Restriction_Warnings | Name_Restrictions); if Arg_Count = 2 and then Import_Check_Required then -- Here is where we cancel the SIS active status if this pragma @@ -444,7 +443,7 @@ package body Ch2 is P := P_Pragma; if Nkind (P) /= N_Error - and then Nam_In (Pragma_Name_Unmapped (P), Name_Assert, Name_Debug) + and then Pragma_Name_Unmapped (P) in Name_Assert | Name_Debug then Error_Msg_Name_1 := Pragma_Name_Unmapped (P); Error_Msg_N diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index d224cc5..adaa3e2 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -123,11 +123,12 @@ package body Ch3 is procedure Check_Restricted_Expression (N : Node_Id) is begin - if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then + if Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor | N_And_Then | N_Or_Else + then Check_Restricted_Expression (Left_Opnd (N)); Check_Restricted_Expression (Right_Opnd (N)); - elsif Nkind_In (N, N_In, N_Not_In) + elsif Nkind (N) in N_In | N_Not_In and then Paren_Count (N) = 0 then Error_Msg_N ("|this expression must be parenthesized!", N); @@ -4777,7 +4778,7 @@ package body Ch3 is -- Complete declaration of mangled subprogram body, for better -- recovery if analysis is attempted. - if Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) + if Nkind (Decl) in N_Subprogram_Body | N_Package_Body | N_Task_Body and then No (Handled_Statement_Sequence (Decl)) then Set_Handled_Statement_Sequence (Decl, diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 4e48a49..9815ca1 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1907,7 +1907,7 @@ package body Ch4 is Logop := P_Logical_Operator; Restore_Scan_State (Scan_State); -- to comma/semicolon - if Nkind_In (Logop, N_And_Then, N_Or_Else) then + if Logop in N_And_Then | N_Or_Else then Scan; -- past comma/semicolon if Com then @@ -3407,6 +3407,8 @@ package body Ch4 is function P_Iterated_Component_Association return Node_Id is Assoc_Node : Node_Id; Id : Node_Id; + Iter_Spec : Node_Id; + Loop_Spec : Node_Id; State : Saved_Scan_State; -- Start of processing for P_Iterated_Component_Association @@ -3423,6 +3425,9 @@ package body Ch4 is -- if E is a subtype indication this is a loop parameter spec, -- while if E a name it is an iterator_specification, and the -- disambiguation takes place during semantic analysis. + -- In addition, if "use" is present after the specification, + -- this is an Iterated_Element_Association that carries a + -- key_expression, and we generate the appropriate node. Id := P_Defining_Identifier; Assoc_Node := @@ -3432,6 +3437,22 @@ package body Ch4 is Set_Defining_Identifier (Assoc_Node, Id); T_In; Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List); + + if Token = Tok_Use then + + -- Key-expression is present, rewrite node as an + -- iterated_Element_Awwoiation. + + Scan; -- past USE + Loop_Spec := + New_Node (N_Loop_Parameter_Specification, Prev_Token_Ptr); + Set_Defining_Identifier (Loop_Spec, Id); + Set_Discrete_Subtype_Definition (Loop_Spec, + First (Discrete_Choices (Assoc_Node))); + Set_Loop_Parameter_Specification (Assoc_Node, Loop_Spec); + Set_Key_Expression (Assoc_Node, P_Expression); + end if; + TF_Arrow; Set_Expression (Assoc_Node, P_Expression); @@ -3441,8 +3462,19 @@ package body Ch4 is Restore_Scan_State (State); Scan; -- past OF Set_Defining_Identifier (Assoc_Node, Id); - Set_Iterator_Specification - (Assoc_Node, P_Iterator_Specification (Id)); + Iter_Spec := P_Iterator_Specification (Id); + Set_Iterator_Specification (Assoc_Node, Iter_Spec); + + if Token = Tok_Use then + Scan; -- past USE + -- This is an iterated_elenent_qssociation. + + Assoc_Node := + New_Node (N_Iterated_Element_Association, Prev_Token_Ptr); + Set_Iterator_Specification (Assoc_Node, Iter_Spec); + Set_Key_Expression (Assoc_Node, P_Expression); + end if; + TF_Arrow; Set_Expression (Assoc_Node, P_Expression); end if; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 49ecb93..5b002c4 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1307,9 +1307,9 @@ package body Ch5 is else if Style_Check and then Paren_Count (Cond) > 0 then - if not Nkind_In (Cond, N_If_Expression, - N_Case_Expression, - N_Quantified_Expression) + if Nkind (Cond) not in N_If_Expression + | N_Case_Expression + | N_Quantified_Expression or else Paren_Count (Cond) > 1 then Style.Check_Xtra_Parens (First_Sloc (Cond)); diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 0821e68..1ff7950 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -883,9 +883,9 @@ package body Ch6 is -- with syntactic parentheses. if not (Paren_Count (Expr) /= 0 - or else Nkind_In (Expr, N_Aggregate, - N_Extension_Aggregate, - N_Quantified_Expression)) + or else Nkind (Expr) in N_Aggregate + | N_Extension_Aggregate + | N_Quantified_Expression) then Error_Msg ("expression function must be enclosed in " diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 0e5a32b..265f187 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -169,7 +169,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is begin if Nkind (Expression (Arg)) /= N_Identifier - or else not Nam_In (Chars (Argx), Name_On, Name_Off) + or else Chars (Argx) not in Name_On | Name_Off then Error_Msg_Name_2 := Name_On; Error_Msg_Name_3 := Name_Off; @@ -435,7 +435,7 @@ begin if Chars (Expression (Arg1)) = Name_On then Extensions_Allowed := True; - Ada_Version := Ada_2012; + Ada_Version := Ada_Version_Type'Last; else Extensions_Allowed := False; Ada_Version := Ada_Version_Explicit; @@ -1311,43 +1311,45 @@ begin when Pragma_Abort_Defer | Pragma_Abstract_State | Pragma_Aggregate_Individually_Assign - | Pragma_Async_Readers - | Pragma_Async_Writers - | Pragma_Assertion_Policy - | Pragma_Assume - | Pragma_Assume_No_Invalid_Values | Pragma_All_Calls_Remote | Pragma_Allow_Integer_Address | Pragma_Annotate | Pragma_Assert | Pragma_Assert_And_Cut + | Pragma_Assertion_Policy + | Pragma_Assume + | Pragma_Assume_No_Invalid_Values + | Pragma_Async_Readers + | Pragma_Async_Writers | Pragma_Asynchronous | Pragma_Atomic | Pragma_Atomic_Components | Pragma_Attach_Handler | Pragma_Attribute_Definition - | Pragma_Check - | Pragma_Check_Float_Overflow - | Pragma_Check_Name - | Pragma_Check_Policy - | Pragma_Compile_Time_Error - | Pragma_Compile_Time_Warning - | Pragma_Constant_After_Elaboration - | Pragma_Contract_Cases - | Pragma_Convention_Identifier | Pragma_CPP_Class | Pragma_CPP_Constructor | Pragma_CPP_Virtual | Pragma_CPP_Vtable | Pragma_CPU + | Pragma_CUDA_Execute + | Pragma_CUDA_Global | Pragma_C_Pass_By_Copy + | Pragma_Check + | Pragma_Check_Float_Overflow + | Pragma_Check_Name + | Pragma_Check_Policy | Pragma_Comment | Pragma_Common_Object + | Pragma_Compile_Time_Error + | Pragma_Compile_Time_Warning | Pragma_Complete_Representation | Pragma_Complex_Representation | Pragma_Component_Alignment + | Pragma_Constant_After_Elaboration + | Pragma_Contract_Cases | Pragma_Controlled | Pragma_Convention + | Pragma_Convention_Identifier | Pragma_Deadline_Floor | Pragma_Debug_Policy | Pragma_Default_Initial_Condition @@ -1446,19 +1448,19 @@ begin | Pragma_Part_Of | Pragma_Partition_Elaboration_Policy | Pragma_Passive - | Pragma_Preelaborable_Initialization - | Pragma_Polling - | Pragma_Prefix_Exception_Messages | Pragma_Persistent_BSS + | Pragma_Polling | Pragma_Post - | Pragma_Postcondition | Pragma_Post_Class + | Pragma_Postcondition | Pragma_Pre + | Pragma_Pre_Class | Pragma_Precondition | Pragma_Predicate | Pragma_Predicate_Failure + | Pragma_Preelaborable_Initialization | Pragma_Preelaborate - | Pragma_Pre_Class + | Pragma_Prefix_Exception_Messages | Pragma_Priority | Pragma_Priority_Specific_Dispatching | Pragma_Profile @@ -1482,6 +1484,7 @@ begin | Pragma_Rename_Pragma | Pragma_Restricted_Run_Time | Pragma_Reviewable + | Pragma_SPARK_Mode | Pragma_Secondary_Stack_Size | Pragma_Share_Generic | Pragma_Shared @@ -1489,7 +1492,6 @@ begin | Pragma_Short_Circuit_And_Or | Pragma_Short_Descriptors | Pragma_Simple_Storage_Pool_Type - | Pragma_SPARK_Mode | Pragma_Static_Elaboration_Desired | Pragma_Storage_Size | Pragma_Storage_Unit diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index a7c64b8..1f26075 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -181,7 +181,7 @@ package body Util is if Ada_Version = Ada_95 and then Warn_On_Ada_2005_Compatibility then - if Nam_In (Token_Name, Name_Overriding, Name_Synchronized) + if Token_Name in Name_Overriding | Name_Synchronized or else (Token_Name = Name_Interface and then Prev_Token /= Tok_Pragma) then diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index ab5625e..1579653 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -459,9 +459,9 @@ package body Par_SCO is function Is_Logical_Operator (N : Node_Id) return Tristate is begin - if Nkind_In (N, N_And_Then, N_Op_Not, N_Or_Else) then + if Nkind (N) in N_And_Then | N_Op_Not | N_Or_Else then return True; - elsif Nkind_In (N, N_Op_And, N_Op_Or) then + elsif Nkind (N) in N_Op_And | N_Op_Or then return Unknown; else return False; @@ -599,9 +599,9 @@ package body Par_SCO is else L := Left_Opnd (N); - if Nkind_In (N, N_Op_Or, N_Or_Else) then + if Nkind (N) in N_Op_Or | N_Or_Else then C1 := '|'; - else pragma Assert (Nkind_In (N, N_Op_And, N_And_Then)); + else pragma Assert (Nkind (N) in N_Op_And | N_And_Then); C1 := '&'; end if; end if; @@ -688,9 +688,9 @@ package body Par_SCO is -- Doesn't this requirement of using First_Sloc need to be -- documented in the spec ??? - if Nkind_In (Parent (N), N_Accept_Alternative, - N_Delay_Alternative, - N_Terminate_Alternative) + if Nkind (Parent (N)) in N_Accept_Alternative + | N_Delay_Alternative + | N_Terminate_Alternative then Loc := First_Sloc (N); else diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index 6bd7573..c00962d 100644 --- a/gcc/ada/pprint.adb +++ b/gcc/ada/pprint.adb @@ -329,12 +329,10 @@ package body Pprint is (Constraint (Subtype_Indication (N))); if List_Length (Ranges) = 1 - and then - Nkind_In - (First (Ranges), - N_Range, - N_Real_Range_Specification, - N_Signed_Integer_Type_Definition) + and then Nkind (First (Ranges)) in + N_Range | + N_Real_Range_Specification | + N_Signed_Integer_Type_Definition then if Id = Attribute_First then return @@ -765,8 +763,7 @@ package body Pprint is -- If argument does not already account for a closing -- parenthesis, count one here. - if not Nkind_In (Right, N_Aggregate, - N_Quantified_Expression) + if Nkind (Right) not in N_Aggregate | N_Quantified_Expression then Append_Paren := Append_Paren + 1; end if; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 1b6eb8a..dff3272 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -527,9 +527,9 @@ package body Repinfo is List_Entities (E, Bytes_Big_Endian, True); - elsif Ekind_In (E, E_Entry, - E_Entry_Family, - E_Subprogram_Type) + elsif Ekind (E) in E_Entry + | E_Entry_Family + | E_Subprogram_Type then if List_Representation_Info_Mechanisms then List_Subprogram_Info (E); @@ -558,9 +558,9 @@ package body Repinfo is -- Note that formals are not annotated so we skip them here - elsif Ekind_In (E, E_Constant, - E_Loop_Parameter, - E_Variable) + elsif Ekind (E) in E_Constant + | E_Loop_Parameter + | E_Variable then if List_Representation_Info >= 2 then List_Object_Info (E); @@ -578,12 +578,12 @@ package body Repinfo is -- Recurse into bodies - elsif Ekind_In (E, E_Package_Body, - E_Protected_Body, - E_Protected_Type, - E_Subprogram_Body, - E_Task_Body, - E_Task_Type) + elsif Ekind (E) in E_Package_Body + | E_Protected_Body + | E_Protected_Type + | E_Subprogram_Body + | E_Task_Body + | E_Task_Type then List_Entities (E, Bytes_Big_Endian); diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 08788d1..c63c881 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -237,7 +237,7 @@ package body Restrict is -- For type conversion, check converted expression - elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then + elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then Check_No_Implicit_Aliasing (Expression (Obj)); return; @@ -746,7 +746,7 @@ package body Restrict is and then Chars (Scope (Ent)) = Name_Ada and then Scope (Scope (Ent)) = Standard_Standard) then - if Nkind_In (Expr, N_Identifier, N_Operator_Symbol) + if Nkind (Expr) in N_Identifier | N_Operator_Symbol and then Chars (Ent) = Chars (Expr) then Error_Msg_Node_1 := N; @@ -763,7 +763,7 @@ package body Restrict is -- Here if at outer level of entity name in table - elsif Nkind_In (Expr, N_Identifier, N_Operator_Symbol) then + elsif Nkind (Expr) in N_Identifier | N_Operator_Symbol then exit; -- Here if neither at the outer level @@ -977,7 +977,7 @@ package body Restrict is and then OK_No_Use_Of_Entity_Name (Selector_Name (N)); - elsif Nkind_In (N, N_Identifier, N_Operator_Symbol) then + elsif Nkind (N) in N_Identifier | N_Operator_Symbol then return True; else @@ -1258,15 +1258,15 @@ package body Restrict is function Same_Entity (E1, E2 : Node_Id) return Boolean is begin - if Nkind_In (E1, N_Identifier, N_Operator_Symbol) + if Nkind (E1) in N_Identifier | N_Operator_Symbol and then - Nkind_In (E2, N_Identifier, N_Operator_Symbol) + Nkind (E2) in N_Identifier | N_Operator_Symbol then return Chars (E1) = Chars (E2); - elsif Nkind_In (E1, N_Selected_Component, N_Expanded_Name) + elsif Nkind (E1) in N_Selected_Component | N_Expanded_Name and then - Nkind_In (E2, N_Selected_Component, N_Expanded_Name) + Nkind (E2) in N_Selected_Component | N_Expanded_Name then return Same_Unit (Prefix (E1), Prefix (E2)) and then @@ -1285,9 +1285,9 @@ package body Restrict is if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then return Chars (U1) = Chars (U2); - elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name) + elsif Nkind (U1) in N_Selected_Component | N_Expanded_Name and then - Nkind_In (U2, N_Selected_Component, N_Expanded_Name) + Nkind (U2) in N_Selected_Component | N_Expanded_Name then return Same_Unit (Prefix (U1), Prefix (U2)) and then @@ -1354,8 +1354,6 @@ package body Restrict is -- Set_Restriction -- --------------------- - -- Case of Boolean restriction - procedure Set_Restriction (R : All_Boolean_Restrictions; N : Node_Id) @@ -1395,8 +1393,6 @@ package body Restrict is end if; end Set_Restriction; - -- Case of parameter restriction - procedure Set_Restriction (R : All_Parameter_Restrictions; N : Node_Id; @@ -1446,6 +1442,29 @@ package body Restrict is Restriction_Profile_Name (R) := No_Profile; end Set_Restriction; + procedure Set_Restriction + (R : All_Restrictions; + N : Node_Id; + Warn : Boolean; + V : Integer := Integer'First) + is + Set : Boolean := True; + begin + if Warn and then Restriction_Active (R) then + Set := False; + end if; + + if Set then + if R in All_Boolean_Restrictions then + Set_Restriction (R, N); + else + Set_Restriction (R, N, V); + end if; + + Restriction_Warnings (R) := Warn; + end if; + end Set_Restriction; + ----------------------------------- -- Set_Restriction_No_Dependence -- ----------------------------------- @@ -1485,7 +1504,7 @@ package body Restrict is procedure Set_Restriction_No_Use_Of_Entity (Entity : Node_Id; - Warning : Boolean; + Warn : Boolean; Profile : Profile_Name := No_Profile) is Nam : Node_Id; @@ -1501,7 +1520,7 @@ package body Restrict is -- Error has precedence over warning - if not Warning then + if not Warn then No_Use_Of_Entity.Table (J).Warn := False; end if; @@ -1511,17 +1530,17 @@ package body Restrict is -- Entry is not currently in table - No_Use_Of_Entity.Append ((Entity, Warning, Profile)); + No_Use_Of_Entity.Append ((Entity, Warn, Profile)); -- Now we need to find the direct name and set Boolean2 flag - if Nkind_In (Entity, N_Identifier, N_Operator_Symbol) then + if Nkind (Entity) in N_Identifier | N_Operator_Symbol then Nam := Entity; else pragma Assert (Nkind (Entity) = N_Selected_Component); Nam := Selector_Name (Entity); - pragma Assert (Nkind_In (Nam, N_Identifier, N_Operator_Symbol)); + pragma Assert (Nkind (Nam) in N_Identifier | N_Operator_Symbol); end if; Set_Name_Table_Boolean2 (Chars (Nam), True); @@ -1532,15 +1551,15 @@ package body Restrict is ------------------------------------------------ procedure Set_Restriction_No_Specification_Of_Aspect - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N)); begin No_Specification_Of_Aspect_Set := True; No_Specification_Of_Aspects (A_Id) := Sloc (N); - No_Specification_Of_Aspect_Warning (A_Id) := Warning; + No_Specification_Of_Aspect_Warning (A_Id) := Warn; end Set_Restriction_No_Specification_Of_Aspect; procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is @@ -1555,15 +1574,15 @@ package body Restrict is ----------------------------------------- procedure Set_Restriction_No_Use_Of_Attribute - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); begin No_Use_Of_Attribute_Set := True; No_Use_Of_Attribute (A_Id) := Sloc (N); - No_Use_Of_Attribute_Warning (A_Id) := Warning; + No_Use_Of_Attribute_Warning (A_Id) := Warn; end Set_Restriction_No_Use_Of_Attribute; procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is @@ -1578,15 +1597,15 @@ package body Restrict is -------------------------------------- procedure Set_Restriction_No_Use_Of_Pragma - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); begin No_Use_Of_Pragma_Set := True; No_Use_Of_Pragma (A_Id) := Sloc (N); - No_Use_Of_Pragma_Warning (A_Id) := Warning; + No_Use_Of_Pragma_Warning (A_Id) := Warn; end Set_Restriction_No_Use_Of_Pragma; procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index a638401..7a84d37 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -452,6 +452,20 @@ package Restrict is -- Similar to the above, except that this is used for the case of a -- parameter restriction, and the corresponding value V is given. + procedure Set_Restriction + (R : All_Restrictions; + N : Node_Id; + Warn : Boolean; + V : Integer := Integer'First); + -- Same as above two, except also takes care of setting the + -- Restriction_Warnings flag. V is ignored for Boolean + -- restrictions. + -- + -- If this is the first time we've seen this restriction, the warning flag + -- is set to Warn. If this is a second or subsequent time, Warn = False + -- wins; that is, errors always trump warnings. In that case, the warning + -- flag can be set to False, but never to True. + procedure Set_Restriction_No_Dependence (Unit : Node_Id; Warn : Boolean; @@ -463,8 +477,8 @@ package Restrict is -- No_Dependence restriction comes from a Profile pragma. procedure Set_Restriction_No_Specification_Of_Aspect - (N : Node_Id; - Warning : Boolean); + (N : Node_Id; + Warn : Boolean); -- N is the node id for an identifier from a pragma Restrictions for the -- No_Specification_Of_Aspect pragma. An error message will be issued if -- the identifier is not a valid aspect name. Warning is set True for the @@ -475,8 +489,8 @@ package Restrict is -- Version used by Get_Target_Parameters (via Tbuild) procedure Set_Restriction_No_Use_Of_Attribute - (N : Node_Id; - Warning : Boolean); + (N : Node_Id; + Warn : Boolean); -- N is the node id for the identifier in a pragma Restrictions for -- No_Use_Of_Attribute. Caller has verified that this is a valid attribute -- designator. @@ -486,7 +500,7 @@ package Restrict is procedure Set_Restriction_No_Use_Of_Entity (Entity : Node_Id; - Warning : Boolean; + Warn : Boolean; Profile : Profile_Name := No_Profile); -- Sets given No_Use_Of_Entity restriction in table if not there already. -- Warn is True if from Restriction_Warnings, or for Restrictions if the @@ -497,8 +511,8 @@ package Restrict is -- the entity (to optimize table searches). procedure Set_Restriction_No_Use_Of_Pragma - (N : Node_Id; - Warning : Boolean); + (N : Node_Id; + Warn : Boolean); -- N is the node id for the identifier in a pragma Restrictions for -- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id. diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 7e617b6..7689375 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -585,6 +585,9 @@ package body Rtsfind is range Ada_Wide_Wide_Text_IO_Decimal_IO .. Ada_Wide_Wide_Text_IO_Modular_IO; + subtype CUDA_Descendant is RTU_Id + range CUDA_Driver_Types .. CUDA_Vector_Types; + subtype Interfaces_Descendant is RTU_Id range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal; @@ -665,6 +668,9 @@ package body Rtsfind is Name_Buffer (22) := '.'; end if; + elsif U_Id in CUDA_Descendant then + Name_Buffer (5) := '.'; + elsif U_Id in Interfaces_Descendant then Name_Buffer (11) := '.'; @@ -898,9 +904,9 @@ package body Rtsfind is return Nkind (Prf) = N_Identifier and then - Nam_In (Chars (Prf), Name_Text_IO, - Name_Wide_Text_IO, - Name_Wide_Wide_Text_IO) + Chars (Prf) in Name_Text_IO + | Name_Wide_Text_IO + | Name_Wide_Wide_Text_IO and then Nkind (Sel) = N_Identifier and then Chars (Sel) in Text_IO_Package_Name; end Is_Text_IO_Special_Unit; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 6a1738b..ff9eb0a 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -159,6 +159,15 @@ package Rtsfind is Ada_Wide_Wide_Text_IO_Integer_IO, Ada_Wide_Wide_Text_IO_Modular_IO, + -- CUDA + + CUDA, + + -- Children of CUDA + + CUDA_Driver_Types, + CUDA_Vector_Types, + -- Interfaces Interfaces, @@ -614,6 +623,10 @@ package Rtsfind is RO_WW_Decimal_IO, -- Ada.Wide_Wide_Text_IO RO_WW_Fixed_IO, -- Ada.Wide_Wide_Text_IO + RE_Stream_T, -- CUDA.Driver_Types + + RE_Dim3, -- CUDA.Vector_Types + RE_Integer_8, -- Interfaces RE_Integer_16, -- Interfaces RE_Integer_32, -- Interfaces @@ -1901,6 +1914,10 @@ package Rtsfind is RO_WW_Decimal_IO => Ada_Wide_Wide_Text_IO, RO_WW_Fixed_IO => Ada_Wide_Wide_Text_IO, + RE_Stream_T => CUDA_Driver_Types, + + RE_Dim3 => CUDA_Vector_Types, + RE_Integer_8 => Interfaces, RE_Integer_16 => Interfaces, RE_Integer_32 => Interfaces, diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb index f7c7287..98ca30d 100644 --- a/gcc/ada/scil_ll.adb +++ b/gcc/ada/scil_ll.adb @@ -120,10 +120,9 @@ package body SCIL_LL is null; when N_SCIL_Membership_Test => - pragma Assert (Nkind_In (N, N_Identifier, - N_And_Then, - N_Or_Else, - N_Expression_With_Actions)); + pragma Assert + (Nkind (N) in N_Identifier | N_And_Then | N_Or_Else | + N_Expression_With_Actions); null; when others => diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index fd3dacc..2bac3a8 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -2485,10 +2485,17 @@ package body Scng is ("wide character not allowed in identifier", Wptr); end if; + -- AI12-0004: An identifier shall only contain characters + -- that may be present in Normalization Form KC. + + if not Is_UTF_32_NFKC (UTF_32 (Code)) then + Error_Msg + ("invalid wide character in identifier", Wptr); + -- If OK letter, store it folding to upper case. Note -- that we include the folded letter in the checksum. - if Is_UTF_32_Letter (Cat) then + elsif Is_UTF_32_Letter (Cat) then Code := Char_Code (UTF_32_To_Upper_Case (UTF_32 (Code))); Accumulate_Checksum (Code); diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 425dafa..4429b6b 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -670,6 +670,9 @@ package body Sem is when N_Iterated_Component_Association => Diagnose_Iterated_Component_Association (N); + when N_Iterated_Element_Association => + null; -- May require a more precise error if misplaced. + -- For the remaining node types, we generate compiler abort, because -- these nodes are always analyzed within the Sem_Chn routines and -- there should never be a case of making a call to the main Analyze @@ -796,7 +799,7 @@ package body Sem is -- and because the reference may become overloaded in the instance. elsif GNATprove_Mode - and then Nkind_In (N, N_Expanded_Name, N_Identifier) + and then Nkind (N) in N_Expanded_Name | N_Identifier and then not Is_Overloaded (N) and then not Inside_A_Generic then @@ -1736,7 +1739,7 @@ package body Sem is begin -- Problem does not arise with main subprograms - if not Nkind_In (MCU, N_Package_Body, N_Package_Declaration) then + if Nkind (MCU) not in N_Package_Body | N_Package_Declaration then return False; end if; @@ -1851,13 +1854,12 @@ package body Sem is -- N_Null_Statement will happen in case of a ghost unit -- which gets rewritten. - if not Nkind_In - (Unit (Withed_Unit), - N_Generic_Package_Declaration, - N_Package_Body, - N_Package_Renaming_Declaration, - N_Subprogram_Body, - N_Null_Statement) + if Nkind (Unit (Withed_Unit)) not in + N_Generic_Package_Declaration | + N_Package_Body | + N_Package_Renaming_Declaration | + N_Subprogram_Body | + N_Null_Statement then Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit))); @@ -1957,7 +1959,7 @@ package body Sem is -- Process the unit if it is a spec or the main unit, if it -- has no previous spec or we have done all other units. - if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) + if Nkind (Item) not in N_Package_Body | N_Subprogram_Body or else Acts_As_Spec (CU) then if CU = Main_CU and then not Do_Main then diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 2383ed0c..f320b32 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -138,7 +138,7 @@ -- this is the one case where this model falls down. Here is how we patch -- it up without causing too much distortion to our basic model. --- A switch (In_Spec_Expression) is set to show that we are in the initial +-- A flag (In_Spec_Expression) is set to show that we are in the initial -- occurrence of a default expression. The analyzer is then called on this -- expression with the switch set true. Analysis and resolution proceed almost -- as usual, except that Freeze_Expression will not freeze non-static diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 2e72846..f77230c 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -960,24 +960,24 @@ package body Sem_Aggr is if Nkind (Parent (N)) = N_Assignment_Statement or else Inside_Init_Proc or else (Is_Constrained (Typ) - and then Nkind_In (Parent (N), - N_Parameter_Association, - N_Function_Call, - N_Procedure_Call_Statement, - N_Generic_Association, - N_Formal_Object_Declaration, - N_Simple_Return_Statement, - N_Object_Declaration, - N_Component_Declaration, - N_Parameter_Specification, - N_Qualified_Expression, - N_Reference, - N_Aggregate, - N_Extension_Aggregate, - N_Component_Association, - N_Case_Expression_Alternative, - N_If_Expression, - N_Expression_With_Actions)) + and then Nkind (Parent (N)) in + N_Parameter_Association + | N_Function_Call + | N_Procedure_Call_Statement + | N_Generic_Association + | N_Formal_Object_Declaration + | N_Simple_Return_Statement + | N_Object_Declaration + | N_Component_Declaration + | N_Parameter_Specification + | N_Qualified_Expression + | N_Reference + | N_Aggregate + | N_Extension_Aggregate + | N_Component_Association + | N_Case_Expression_Alternative + | N_If_Expression + | N_Expression_With_Actions) then Aggr_Resolved := Resolve_Array_Aggregate @@ -1424,7 +1424,7 @@ package body Sem_Aggr is if Is_Character_Type (Component_Typ) and then No (Next_Index (Nxt_Ind)) - and then Nkind_In (Expr, N_String_Literal, N_Operator_Symbol) + and then Nkind (Expr) in N_String_Literal | N_Operator_Symbol then -- A string literal used in a multidimensional array -- aggregate in place of the final one-dimensional @@ -1698,8 +1698,8 @@ package body Sem_Aggr is if Ada_Version = Ada_83 and then Assoc /= First (Component_Associations (N)) - and then Nkind_In (Parent (N), N_Assignment_Statement, - N_Object_Declaration) + and then Nkind (Parent (N)) in + N_Assignment_Statement | N_Object_Declaration then Error_Msg_N ("(Ada 83) illegal context for OTHERS choice", N); @@ -2644,6 +2644,18 @@ package body Sem_Aggr is --------------------------------- procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is + procedure Resolve_Iterated_Component_Association + (Comp : Node_Id; + Key_Type : Entity_Id; + Elmt_Type : Entity_Id); + -- Resolve choices and expression in an iterated component association. + -- This is similar but not identical to the handling of this construct + -- in an array aggregate. + -- For a named container, the type of each choice must be compatible + -- with the key type. For a positional container, the choice must be + -- a subtype indication or an iterator specification that determines + -- an element type. + Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate); Empty_Subp : Node_Id := Empty; @@ -2652,41 +2664,232 @@ package body Sem_Aggr is New_Indexed_Subp : Node_Id := Empty; Assign_Indexed_Subp : Node_Id := Empty; + -------------------------------------------- + -- Resolve_Iterated_Component_Association -- + -------------------------------------------- + + procedure Resolve_Iterated_Component_Association + (Comp : Node_Id; + Key_Type : Entity_Id; + Elmt_Type : Entity_Id) + is + Choice : Node_Id; + Ent : Entity_Id; + Expr : Node_Id; + Id : Entity_Id; + Iter : Node_Id; + Typ : Entity_Id := Empty; + + begin + if Present (Iterator_Specification (Comp)) then + Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + Analyze (Iter); + Typ := Etype (Defining_Identifier (Iter)); + + else + Choice := First (Discrete_Choices (Comp)); + + while Present (Choice) loop + Analyze (Choice); + + -- Choice can be a subtype name, a range, or an expression + + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + and then Base_Type (Entity (Choice)) = Base_Type (Key_Type) + then + null; + + elsif Present (Key_Type) then + Analyze_And_Resolve (Choice, Key_Type); + + else + Typ := Etype (Choice); -- assume unique for now + end if; + + Next (Choice); + end loop; + end if; + + -- Create a scope in which to introduce an index, which is usually + -- visible in the expression for the component, and needed for its + -- analysis. + + Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (Comp), 'L'); + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, Parent (Comp)); + Push_Scope (Ent); + Id := + Make_Defining_Identifier (Sloc (Comp), + Chars => Chars (Defining_Identifier (Comp))); + + -- Insert and decorate the loop variable in the current scope. + -- The expression has to be analyzed once the loop variable is + -- directly visible. Mark the variable as referenced to prevent + -- spurious warnings, given that subsequent uses of its name in the + -- expression will reference the internal (synonym) loop variable. + + Enter_Name (Id); + + if No (Key_Type) then + pragma Assert (Present (Typ)); + Set_Etype (Id, Typ); + else + Set_Etype (Id, Key_Type); + end if; + + Set_Ekind (Id, E_Variable); + Set_Scope (Id, Ent); + Set_Referenced (Id); + + -- Analyze a copy of the expression, to verify legality. We use + -- a copy because the expression will be analyzed anew when the + -- enclosing aggregate is expanded, and the construct is rewritten + -- as a loop with a new index variable. + + Expr := New_Copy_Tree (Expression (Comp)); + Preanalyze_And_Resolve (Expr, Elmt_Type); + End_Scope; + end Resolve_Iterated_Component_Association; + begin - if Nkind (Asp) /= N_Aggregate then - pragma Assert (False); - return; - else - Set_Etype (N, Typ); - Parse_Aspect_Aggregate (Asp, - Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, - New_Indexed_Subp, Assign_Indexed_Subp); + pragma Assert (Nkind (Asp) = N_Aggregate); - if Present (Add_Unnamed_Subp) then - declare - Elmt_Type : constant Entity_Id := - Etype (Next_Formal - (First_Formal (Entity (Add_Unnamed_Subp)))); - Comp : Node_Id; - begin - if Present (Expressions (N)) then - -- positional aggregate + Set_Etype (N, Typ); + Parse_Aspect_Aggregate (Asp, + Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, + New_Indexed_Subp, Assign_Indexed_Subp); - Comp := First (Expressions (N)); + if Present (Add_Unnamed_Subp) + and then No (New_Indexed_Subp) + then + declare + Elmt_Type : constant Entity_Id := + Etype (Next_Formal + (First_Formal (Entity (Add_Unnamed_Subp)))); + Comp : Node_Id; + + begin + if Present (Expressions (N)) then + -- positional aggregate + + Comp := First (Expressions (N)); + while Present (Comp) loop + Analyze_And_Resolve (Comp, Elmt_Type); + Next (Comp); + end loop; + end if; + + -- Empty aggregate, to be replaced by Empty during + -- expansion, or iterated component association. + + if Present (Component_Associations (N)) then + declare + Comp : Node_Id := First (Component_Associations (N)); + begin while Present (Comp) loop - Analyze_And_Resolve (Comp, Elmt_Type); + if Nkind (Comp) /= + N_Iterated_Component_Association + then + Error_Msg_N ("illegal component association " + & "for unnamed container aggregate", Comp); + return; + else + Resolve_Iterated_Component_Association + (Comp, Empty, Elmt_Type); + end if; + Next (Comp); end loop; - else + end; + end if; + end; - -- Empty aggregate, to be replaced by Empty during - -- expansion. - null; + elsif Present (Add_Named_Subp) then + declare + -- Retrieves types of container, key, and element from the + -- specified insertion procedure. + + Container : constant Entity_Id := + First_Formal (Entity (Add_Named_Subp)); + Key_Type : constant Entity_Id := Etype (Next_Formal (Container)); + Elmt_Type : constant Entity_Id := + Etype (Next_Formal (Next_Formal (Container))); + Comp : Node_Id; + Choice : Node_Id; + + begin + Comp := First (Component_Associations (N)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Association then + Choice := First (Choices (Comp)); + + while Present (Choice) loop + Analyze_And_Resolve (Choice, Key_Type); + if not Is_Static_Expression (Choice) then + Error_Msg_N ("Choice must be static", Choice); + end if; + + Next (Choice); + end loop; + + Analyze_And_Resolve (Expression (Comp), Elmt_Type); + + elsif Nkind (Comp) = N_Iterated_Component_Association then + Resolve_Iterated_Component_Association + (Comp, Key_Type, Elmt_Type); end if; - end; - else - Error_Msg_N ("indexed aggregates are forthcoming", N); - end if; + + Next (Comp); + end loop; + end; + + else + -- Indexed Aggregate. Both positional and indexed component + -- can be present. Choices must be static values or ranges + -- with static bounds. + + declare + Container : constant Entity_Id := + First_Formal (Entity (Assign_Indexed_Subp)); + Index_Type : constant Entity_Id := Etype (Next_Formal (Container)); + Comp_Type : constant Entity_Id := + Etype (Next_Formal (Next_Formal (Container))); + Comp : Node_Id; + Choice : Node_Id; + + begin + if Present (Expressions (N)) then + Comp := First (Expressions (N)); + while Present (Comp) loop + Analyze_And_Resolve (Comp, Comp_Type); + Next (Comp); + end loop; + end if; + + if Present (Component_Associations (N)) then + Comp := First (Expressions (N)); + + while Present (Comp) loop + if Nkind (Comp) = N_Component_Association then + Choice := First (Choices (Comp)); + + while Present (Choice) loop + Analyze_And_Resolve (Choice, Index_Type); + Next (Choice); + end loop; + + Analyze_And_Resolve (Expression (Comp), Comp_Type); + + elsif Nkind (Comp) = N_Iterated_Component_Association then + Resolve_Iterated_Component_Association + (Comp, Index_Type, Comp_Type); + end if; + + Next (Comp); + end loop; + end if; + end; end if; end Resolve_Container_Aggregate; @@ -3050,9 +3253,9 @@ package body Sem_Aggr is -- The ancestor must be a call or an aggregate, but a call may -- have been expanded into a temporary, so check original node. - elsif Nkind_In (Anc, N_Aggregate, - N_Extension_Aggregate, - N_Function_Call) + elsif Nkind (Anc) in N_Aggregate + | N_Extension_Aggregate + | N_Function_Call then return True; @@ -3982,7 +4185,7 @@ package body Sem_Aggr is function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is begin return - (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) + (Nkind (Expr) in N_Aggregate | N_Extension_Aggregate and then Present (Etype (Expr)) and then Is_Record_Type (Etype (Expr)) and then Expansion_Delayed (Expr)) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1d4ef0b..e3c027d 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -650,7 +650,8 @@ package body Sem_Attr is -- tracked value. If the scope is a loop or block, indicate that -- value tracking is disabled for the enclosing subprogram. - function Get_Kind (E : Entity_Id) return Entity_Kind; + function Get_Convention (E : Entity_Id) return Convention_Id; + function Get_Kind (E : Entity_Id) return Entity_Kind; -- Distinguish between access to regular/protected subprograms ------------------------ @@ -666,13 +667,33 @@ package body Sem_Attr is end if; end Check_Local_Access; + -------------------- + -- Get_Convention -- + -------------------- + + function Get_Convention (E : Entity_Id) return Convention_Id is + begin + -- Restrict handling by_protected_procedure access subprograms + -- to source entities; required to avoid building access to + -- subprogram types with convention protected when building + -- dispatch tables. + + if Comes_From_Source (P) + and then Is_By_Protected_Procedure (E) + then + return Convention_Protected; + else + return Convention (E); + end if; + end Get_Convention; + -------------- -- Get_Kind -- -------------- function Get_Kind (E : Entity_Id) return Entity_Kind is begin - if Convention (E) = Convention_Protected then + if Get_Convention (E) = Convention_Protected then return E_Access_Protected_Subprogram_Type; else return E_Access_Subprogram_Type; @@ -717,7 +738,7 @@ package body Sem_Attr is Acc_Type := Create_Itype (Get_Kind (Entity (P)), N); Set_Is_Public (Acc_Type, False); Set_Etype (Acc_Type, Acc_Type); - Set_Convention (Acc_Type, Convention (Entity (P))); + Set_Convention (Acc_Type, Get_Convention (Entity (P))); Set_Directly_Designated_Type (Acc_Type, Entity (P)); Set_Etype (N, Acc_Type); Freeze_Before (N, Acc_Type); @@ -732,7 +753,7 @@ package body Sem_Attr is Acc_Type := Create_Itype (Get_Kind (It.Nam), N); Set_Is_Public (Acc_Type, False); Set_Etype (Acc_Type, Acc_Type); - Set_Convention (Acc_Type, Convention (It.Nam)); + Set_Convention (Acc_Type, Get_Convention (It.Nam)); Set_Directly_Designated_Type (Acc_Type, It.Nam); Add_One_Interp (N, Acc_Type, Acc_Type); Freeze_Before (N, Acc_Type); @@ -765,7 +786,7 @@ package body Sem_Attr is (Nkind (Par) = N_Component_Association or else Nkind (Par) in N_Subexpr) loop - if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then + if Nkind (Par) in N_Aggregate | N_Extension_Aggregate then if Etype (Par) = Typ then Set_Has_Self_Reference (Par); @@ -967,9 +988,10 @@ package body Sem_Attr is if not In_Spec_Expression and then not Has_Completion (Scop) - and then not - Nkind_In (Parent (N), N_Discriminant_Association, - N_Index_Or_Discriminant_Constraint) + and then + Nkind (Parent (N)) not in + N_Discriminant_Association | + N_Index_Or_Discriminant_Constraint then Error_Msg_N ("current instance attribute must appear alone", N); @@ -1092,8 +1114,7 @@ package body Sem_Attr is Kill_Current_Values (Ent); exit; - elsif Nkind_In (PP, N_Selected_Component, - N_Indexed_Component) + elsif Nkind (PP) in N_Selected_Component | N_Indexed_Component then PP := Prefix (PP); @@ -1147,10 +1168,10 @@ package body Sem_Attr is begin -- The "Name" argument of pragma Check denotes a postcondition - if Nam_In (Nam, Name_Post, - Name_Post_Class, - Name_Postcondition, - Name_Refined_Post) + if Nam in Name_Post + | Name_Post_Class + | Name_Postcondition + | Name_Refined_Post then null; @@ -1296,7 +1317,7 @@ package body Sem_Attr is Prag := N; while Present (Prag) loop - if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then + if Nkind (Prag) in N_Aspect_Specification | N_Pragma then exit; -- Prevent the search from going too far @@ -1311,7 +1332,7 @@ package body Sem_Attr is -- The attribute is allowed to appear only in postcondition-like -- aspects or pragmas. - if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then + if Nkind (Prag) in N_Aspect_Specification | N_Pragma then if Nkind (Prag) = N_Aspect_Specification then Prag_Nam := Chars (Identifier (Prag)); else @@ -1327,7 +1348,7 @@ package body Sem_Attr is -- Attribute 'Result is allowed to appear in aspect or pragma -- [Refined_]Depends (SPARK RM 6.1.5(11)). - elsif Nam_In (Prag_Nam, Name_Depends, Name_Refined_Depends) + elsif Prag_Nam in Name_Depends | Name_Refined_Depends and then Aname = Name_Result then null; @@ -1340,10 +1361,10 @@ package body Sem_Attr is then null; - elsif Nam_In (Prag_Nam, Name_Post, - Name_Post_Class, - Name_Postcondition, - Name_Refined_Post) + elsif Prag_Nam in Name_Post + | Name_Post_Class + | Name_Postcondition + | Name_Refined_Post then null; @@ -1387,14 +1408,14 @@ package body Sem_Attr is then null; - elsif not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration, - N_Entry_Declaration, - N_Expression_Function, - N_Generic_Subprogram_Declaration, - N_Subprogram_Body, - N_Subprogram_Body_Stub, - N_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + elsif Nkind (Subp_Decl) not in N_Abstract_Subprogram_Declaration + | N_Entry_Declaration + | N_Expression_Function + | N_Generic_Subprogram_Declaration + | N_Subprogram_Body + | N_Subprogram_Body_Stub + | N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration then return; end if; @@ -1436,16 +1457,11 @@ package body Sem_Attr is procedure Check_Image_Type (Image_Type : Entity_Id) is begin - if Ada_Version >= Ada_2020 then - null; -- all types are OK - elsif not Is_Scalar_Type (Image_Type) then - if Ada_Version >= Ada_2012 then - Error_Attr_P - ("prefix of % attribute must be a scalar type or a scalar " - & "object name"); - else - Error_Attr_P ("prefix of % attribute must be a scalar type"); - end if; + if Ada_Version < Ada_2020 + and then not Is_Scalar_Type (Image_Type) + then + Error_Msg_Ada_2020_Feature ("|nonscalar ''Image", Sloc (P)); + Error_Attr; end if; end Check_Image_Type; @@ -1462,7 +1478,7 @@ package body Sem_Attr is Check_Image_Type (Etype (P)); if Attr_Id /= Attribute_Img and then Ada_Version < Ada_2012 then - Error_Attr_P ("prefix of % attribute must be a scalar type"); + Error_Msg_Ada_2012_Feature ("|Object''Image", Sloc (P)); end if; else Check_E1; @@ -1884,9 +1900,9 @@ package body Sem_Attr is -- the prefix of another attribute. Error is posted on parent. if Nkind (Parent (N)) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Parent (N)), Name_Address, - Name_Code_Address, - Name_Access) + and then Attribute_Name (Parent (N)) in Name_Address + | Name_Code_Address + | Name_Access then Error_Msg_Name_1 := Attribute_Name (Parent (N)); Error_Msg_N ("illegal prefix for % attribute", Parent (N)); @@ -2345,8 +2361,8 @@ package body Sem_Attr is -- parameter or component association, which is wrong. if Is_List_Member (N) - and then not Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Aggregate) + and then Nkind (Parent (N)) not in + N_Procedure_Call_Statement | N_Aggregate then null; else @@ -2402,8 +2418,8 @@ package body Sem_Attr is null; elsif Is_List_Member (N) - and then not Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Aggregate) + and then Nkind (Parent (N)) not in + N_Procedure_Call_Statement | N_Aggregate then null; @@ -2641,7 +2657,7 @@ package body Sem_Attr is if Nkind (Nod) = N_Identifier then return; - elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then + elsif Nkind (Nod) in N_Selected_Component | N_Expanded_Name then Check_Unit_Name (Prefix (Nod)); if Nkind (Selector_Name (Nod)) = N_Identifier then @@ -3011,7 +3027,7 @@ package body Sem_Attr is -- parameterless call. Entry attributes are handled specially below. if Is_Entity_Name (P) - and then not Nam_In (Aname, Name_Count, Name_Caller) + and then Aname not in Name_Count | Name_Caller then Check_Parameterless_Call (P); end if; @@ -3022,7 +3038,7 @@ package body Sem_Attr is -- primitive entry wrappers, the attributes Count, and Caller -- require a context check - if Nam_In (Aname, Name_Count, Name_Caller) then + if Aname in Name_Count | Name_Caller then declare Count : Natural := 0; I : Interp_Index; @@ -3320,7 +3336,7 @@ package body Sem_Attr is begin Check_E0; - if Nkind_In (P, N_Identifier, N_Expanded_Name) then + if Nkind (P) in N_Identifier | N_Expanded_Name then Ent := Entity (P); if not Is_Entry (Ent) then @@ -3390,7 +3406,7 @@ package body Sem_Attr is Check_E0; if Nkind (P) = N_Attribute_Reference - and then Nam_In (Attribute_Name (P), Name_Elab_Body, Name_Elab_Spec) + and then Attribute_Name (P) in Name_Elab_Body | Name_Elab_Spec then null; @@ -3540,7 +3556,7 @@ package body Sem_Attr is return; -- Also allow an object of a generic type if extensions allowed - -- and allow this for any type at all. (this may be obsolete ???) + -- and allow this for any type at all. elsif (Is_Generic_Type (P_Type) or else Is_Generic_Actual_Type (P_Type)) @@ -3577,7 +3593,7 @@ package body Sem_Attr is begin Check_E0; - if Nkind_In (P, N_Identifier, N_Expanded_Name) then + if Nkind (P) in N_Identifier | N_Expanded_Name then Ent := Entity (P); if Ekind (Ent) /= E_Entry then @@ -3643,10 +3659,10 @@ package body Sem_Attr is exit; elsif Ekind (Scope (Ent)) in Task_Kind - and then not Ekind_In (S, E_Block, - E_Entry, - E_Entry_Family, - E_Loop) + and then Ekind (S) not in E_Block + | E_Entry + | E_Entry_Family + | E_Loop then Error_Attr ("Attribute % cannot appear in inner unit", N); @@ -4517,12 +4533,13 @@ package body Sem_Attr is -- that the pragma appears in an appropriate loop location. if Nkind (Original_Node (Stmt)) = N_Pragma - and then Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)), - Name_Loop_Invariant, - Name_Loop_Variant, - Name_Assert, - Name_Assert_And_Cut, - Name_Assume) + and then + Pragma_Name_Unmapped (Original_Node (Stmt)) + in Name_Loop_Invariant + | Name_Loop_Variant + | Name_Assert + | Name_Assert_And_Cut + | Name_Assume then Encl_Prag := Original_Node (Stmt); @@ -4585,7 +4602,7 @@ package body Sem_Attr is if Ekind (Scop) = E_Loop and then Scop = Loop_Id then exit; - elsif Ekind_In (Scop, E_Block, E_Loop, E_Return_Statement) then + elsif Ekind (Scop) in E_Block | E_Loop | E_Return_Statement then null; else Error_Attr @@ -4979,8 +4996,7 @@ package body Sem_Attr is -- another attribute 'Old. if Nkind (Nod) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Nod), Name_Old, - Name_Result) + and then Attribute_Name (Nod) in Name_Old | Name_Result then Error_Msg_Name_1 := Attribute_Name (Nod); Error_Msg_Name_2 := Name_Old; @@ -5125,7 +5141,7 @@ package body Sem_Attr is then Pref_Id := Entity (Name (P)); - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) + if Ekind (Spec_Id) in E_Function | E_Generic_Function and then Pref_Id = Spec_Id then Error_Msg_Warn := SPARK_Mode /= On; @@ -5411,7 +5427,7 @@ package body Sem_Attr is elsif Nkind (Subp_Spec) = N_Function_Specification and then Present (Generic_Parent (Subp_Spec)) - and then Ekind_In (Pref_Id, E_Generic_Function, E_Function) + and then Ekind (Pref_Id) in E_Generic_Function | E_Function then if Generic_Parent (Subp_Spec) = Pref_Id then return True; @@ -5517,7 +5533,7 @@ package body Sem_Attr is -- functions, or the prefix must be generic and the spec -- must be nongeneric (i.e. it must denote an instance). - if (Ekind_In (Pref_Id, E_Function, E_Generic_Function) + if (Ekind (Pref_Id) in E_Function | E_Generic_Function and then Ekind (Pref_Id) = Ekind (Spec_Id)) or else (Ekind (Pref_Id) = E_Generic_Function @@ -6594,7 +6610,7 @@ package body Sem_Attr is Negative := False; end if; - if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then + if Nkind (Expr) not in N_Integer_Literal | N_Real_Literal then Error_Attr ("named number for % attribute must be simple literal", N); end if; @@ -7793,8 +7809,7 @@ package body Sem_Attr is begin -- P'Enum_Rep case - if Ekind_In (Entity (P), E_Constant, - E_Enumeration_Literal) + if Ekind (Entity (P)) in E_Constant | E_Enumeration_Literal then Enum_Expr := P; @@ -8090,7 +8105,7 @@ package body Sem_Attr is -- Second foldable possibility is an array object (RM 4.9(8)) - elsif Ekind_In (P_Entity, E_Variable, E_Constant) + elsif Ekind (P_Entity) in E_Variable | E_Constant and then Is_Array_Type (Etype (P_Entity)) and then (not Is_Generic_Type (Etype (P_Entity))) then @@ -10461,10 +10476,10 @@ package body Sem_Attr is -- An exception is the GNAT attribute Constrained_Array which is -- defined to be a static attribute in all cases. - if Nkind_In (N, N_Integer_Literal, - N_Real_Literal, - N_Character_Literal, - N_String_Literal) + if Nkind (N) in N_Integer_Literal + | N_Real_Literal + | N_Character_Literal + | N_String_Literal or else (Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Enumeration_Literal) then @@ -10535,6 +10550,13 @@ package body Sem_Attr is -- Returns True if Declared_Entity is declared within the declarative -- region of Generic_Unit; otherwise returns False. + function Prefix_With_Safe_Accessibility_Level return Boolean; + -- Return True if the prefix does not have a value conversion of an + -- array because a value conversion is like an aggregate with respect + -- to determining accessibility level (RM 3.10.2); even if evaluation + -- of a value conversion is guaranteed to not create a new object, + -- accessibility rules are defined as if it might. + --------------------------- -- Accessibility_Message -- --------------------------- @@ -10564,8 +10586,8 @@ package body Sem_Attr is if Is_Record_Type (Current_Scope) and then - Nkind_In (Parent (N), N_Discriminant_Association, - N_Index_Or_Discriminant_Constraint) + Nkind (Parent (N)) in N_Discriminant_Association + | N_Index_Or_Discriminant_Constraint then Indic := Parent (Parent (N)); while Present (Indic) @@ -10611,6 +10633,70 @@ package body Sem_Attr is return False; end Declared_Within_Generic_Unit; + ------------------------------------------ + -- Prefix_With_Safe_Accessibility_Level -- + ------------------------------------------ + + function Prefix_With_Safe_Accessibility_Level return Boolean is + function Safe_Value_Conversions return Boolean; + -- Return False if the prefix has a value conversion of an array type + + ---------------------------- + -- Safe_Value_Conversions -- + ---------------------------- + + function Safe_Value_Conversions return Boolean is + PP : Node_Id := P; + + begin + loop + if Nkind (PP) in N_Selected_Component | N_Indexed_Component then + PP := Prefix (PP); + + elsif Comes_From_Source (PP) + and then Nkind (PP) in N_Type_Conversion + | N_Unchecked_Type_Conversion + and then Is_Array_Type (Etype (PP)) + then + return False; + + elsif Comes_From_Source (PP) + and then Nkind (PP) = N_Qualified_Expression + and then Is_Array_Type (Etype (PP)) + and then Nkind (Original_Node (Expression (PP))) in + N_Aggregate | N_Extension_Aggregate + then + return False; + + else + exit; + end if; + end loop; + + return True; + end Safe_Value_Conversions; + + -- Start of processing for Prefix_With_Safe_Accessibility_Level + + begin + -- No check required for unchecked and unrestricted access + + if Attr_Id = Attribute_Unchecked_Access + or else Attr_Id = Attribute_Unrestricted_Access + then + return True; + + -- Check value conversions + + elsif Ekind (Btyp) = E_General_Access_Type + and then not Safe_Value_Conversions + then + return False; + end if; + + return True; + end Prefix_With_Safe_Accessibility_Level; + -- Start of processing for Resolve_Attribute begin @@ -10692,19 +10778,6 @@ package body Sem_Attr is end; end if; - -- The following comes from a query concerning improper use of - -- universal_access in equality tests involving anonymous access - -- types. Another good reason for 'Ref, but for now disable the - -- test, which breaks several filed tests??? - - if Ekind (Typ) = E_Anonymous_Access_Type - and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne) - and then False - then - Error_Msg_N ("need unique type to resolve 'Access", N); - Error_Msg_N ("\qualify attribute with some access type", N); - end if; - -- Case where prefix is an entity name if Is_Entity_Name (P) then @@ -10799,10 +10872,10 @@ package body Sem_Attr is -- also be accessibility checks on those, this is where the -- checks can eventually be centralized ??? - if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, - E_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Subprogram_Type) + if Ekind (Btyp) in E_Access_Protected_Subprogram_Type + | E_Access_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Subprogram_Type then -- Deal with convention mismatch @@ -11023,7 +11096,29 @@ package body Sem_Attr is end if; Resolve (Prefix (P)); - Generate_Reference (Entity (Selector_Name (P)), P); + + if not Is_Overloaded (P) then + Generate_Reference (Entity (Selector_Name (P)), P); + + else + Get_First_Interp (P, Index, It); + while Present (It.Nam) loop + if Type_Conformant (Designated_Type (Typ), It.Nam) then + Set_Entity (Selector_Name (P), It.Nam); + + -- The prefix is definitely NOT overloaded anymore at + -- this point, so we reset the Is_Overloaded flag to + -- avoid any confusion when reanalyzing the node. + + Set_Is_Overloaded (P, False); + Set_Is_Overloaded (N, False); + Generate_Reference (Entity (Selector_Name (P)), P); + exit; + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; -- Implement check implied by 3.10.2 (18.1/2) : F.all'access is -- statically illegal if F is an anonymous access to subprogram. @@ -11296,8 +11391,8 @@ package body Sem_Attr is end if; end if; - if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type) + if Ekind (Btyp) in E_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type then if Is_Entity_Name (P) and then not Is_Protected_Type (Scope (Entity (P))) @@ -11334,8 +11429,8 @@ package body Sem_Attr is Check_Internal_Protected_Use (N, Entity (P)); end if; - elsif Ekind_In (Btyp, E_Access_Subprogram_Type, - E_Anonymous_Access_Subprogram_Type) + elsif Ekind (Btyp) in E_Access_Subprogram_Type + | E_Anonymous_Access_Subprogram_Type and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type then Error_Msg_F ("context requires a non-protected subprogram", P); @@ -11430,6 +11525,15 @@ package body Sem_Attr is end if; end if; + -- Check that the prefix does not have a value conversion of an + -- array type since a value conversion is like an aggregate with + -- respect to determining accessibility level (RM 3.10.2). + + if not Prefix_With_Safe_Accessibility_Level then + Accessibility_Message; + return; + end if; + -- Mark that address of entity is taken in case of -- 'Unrestricted_Access or in case of a subprogram. @@ -11468,7 +11572,7 @@ package body Sem_Attr is and then Comes_From_Source (Subp_Id) and then Comes_From_Source (N) and then In_Open_Scopes (Scop) - and then Ekind_In (Scop, E_Block, E_Procedure, E_Function) + and then Ekind (Scop) in E_Block | E_Procedure | E_Function and then not Has_Completion (Subp_Id) and then No (Elaboration_Entity (Subp_Id)) and then Nkind (Subp_Decl) = N_Subprogram_Declaration diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 77f212c..4a16c12 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -711,11 +711,11 @@ package body Sem_Aux is begin pragma Assert - (Nkind_In (N, N_Aspect_Specification, - N_Attribute_Definition_Clause, - N_Enumeration_Representation_Clause, - N_Pragma, - N_Record_Representation_Clause)); + (Nkind (N) in N_Aspect_Specification + | N_Attribute_Definition_Clause + | N_Enumeration_Representation_Clause + | N_Pragma + | N_Record_Representation_Clause); Item := First_Rep_Item (E); while Present (Item) loop @@ -877,13 +877,9 @@ package body Sem_Aux is function Is_Body (N : Node_Id) return Boolean is begin - return - Nkind (N) in N_Body_Stub - or else Nkind_In (N, N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body); + return Nkind (N) in + N_Body_Stub | N_Entry_Body | N_Package_Body | N_Protected_Body | + N_Subprogram_Body | N_Task_Body; end Is_Body; --------------------- @@ -1072,8 +1068,7 @@ package body Sem_Aux is Kind := Nkind (Original_Node (Parent (E))); return - Nkind_In (Kind, N_Formal_Object_Declaration, - N_Formal_Type_Declaration) + Kind in N_Formal_Object_Declaration | N_Formal_Type_Declaration or else Is_Formal_Subprogram (E) or else (Ekind (E) = E_Package diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 5bb94e2..6cda6a9 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -998,7 +998,8 @@ package body Sem_Case is function Lit_Of (Value : Uint) return Node_Id; -- Returns the Node_Id for the enumeration literal corresponding to the - -- position given by Value within the enumeration type Choice_Type. + -- position given by Value within the enumeration type Choice_Type. The + -- returned value has its Is_Static_Expression flag set to true. ------------------ -- Build_Choice -- @@ -1012,10 +1013,11 @@ package body Sem_Case is -- If there is only one choice value missing between Value1 and -- Value2, build an integer or enumeration literal to represent it. - if (Value2 - Value1) = 0 then + if Value1 = Value2 then if Is_Integer_Type (Choice_Type) then Lit_Node := Make_Integer_Literal (Loc, Value1); Set_Etype (Lit_Node, Choice_Type); + Set_Is_Static_Expression (Lit_Node); else Lit_Node := Lit_Of (Value1); end if; @@ -1028,8 +1030,10 @@ package body Sem_Case is if Is_Integer_Type (Choice_Type) then Lo := Make_Integer_Literal (Loc, Value1); Set_Etype (Lo, Choice_Type); + Set_Is_Static_Expression (Lo); Hi := Make_Integer_Literal (Loc, Value2); Set_Etype (Hi, Choice_Type); + Set_Is_Static_Expression (Hi); Lit_Node := Make_Range (Loc, Low_Bound => Lo, diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 8d785af..be1e67e 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -793,8 +793,8 @@ package body Sem_Cat is if Ekind (E) in Subprogram_Kind then Declaration := Unit_Declaration_Node (E); - if Nkind_In (Declaration, N_Subprogram_Body, - N_Subprogram_Renaming_Declaration) + if Nkind (Declaration) in + N_Subprogram_Body | N_Subprogram_Renaming_Declaration then Specification := Corresponding_Spec (Declaration); end if; @@ -1003,7 +1003,7 @@ package body Sem_Cat is -- Body of RCI unit does not need validation if Is_Remote_Call_Interface (E) - and then Nkind_In (N, N_Package_Body, N_Subprogram_Body) + and then Nkind (N) in N_Package_Body | N_Subprogram_Body then return; end if; @@ -1506,8 +1506,8 @@ package body Sem_Cat is null; - elsif Ekind_In (Param_Type, E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + elsif Ekind (Param_Type) in E_Anonymous_Access_Type + | E_Anonymous_Access_Subprogram_Type then -- From RM E.2.2(14), no anonymous access parameter other than -- controlling ones may be used (because an anonymous access @@ -1583,9 +1583,9 @@ package body Sem_Cat is ("limited type not allowed in rci unit", Parent (E)); Explain_Limited_Type (E, Parent (E)); - elsif Ekind_In (E, E_Generic_Function, - E_Generic_Package, - E_Generic_Procedure) + elsif Ekind (E) in E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure then Error_Msg_N ("generic declaration not allowed in rci unit", Parent (E)); diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index c79bd58..76b68a1 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -413,8 +413,8 @@ package body Sem_Ch10 is elsif Nkind (Cont_Item) = N_Pragma and then - Nam_In (Pragma_Name_Unmapped (Cont_Item), - Name_Elaborate, Name_Elaborate_All) + Pragma_Name_Unmapped (Cont_Item) + in Name_Elaborate | Name_Elaborate_All and then not Used_Type_Or_Elab then Prag_Unit := @@ -724,8 +724,8 @@ package body Sem_Ch10 is -- Verify that the library unit is a package declaration - if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration, - N_Generic_Package_Declaration) + if Nkind (Unit (Lib_Unit)) not in + N_Package_Declaration | N_Generic_Package_Declaration then Error_Msg_N ("no legal package declaration for package body", N); @@ -952,8 +952,8 @@ package body Sem_Ch10 is -- Analyze the contract of a [generic] subprogram that acts as a -- compilation unit after all compilation pragmas have been analyzed. - if Nkind_In (Unit_Node, N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) + if Nkind (Unit_Node) in + N_Generic_Subprogram_Declaration | N_Subprogram_Declaration then Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Unit_Node)); end if; @@ -998,10 +998,10 @@ package body Sem_Ch10 is -- next compilation, which is either the main unit or some other unit -- in the context. - if Nkind_In (Unit_Node, N_Package_Declaration, - N_Package_Renaming_Declaration, - N_Subprogram_Declaration) - or else Nkind (Unit_Node) in N_Generic_Declaration + if Nkind (Unit_Node) in N_Package_Declaration + | N_Package_Renaming_Declaration + | N_Subprogram_Declaration + | N_Generic_Declaration or else (Nkind (Unit_Node) = N_Subprogram_Body and then Acts_As_Spec (Unit_Node)) then @@ -1149,9 +1149,9 @@ package body Sem_Ch10 is -- are triggered by these subprograms. if GNATprove_Mode - and then Nkind_In (Unit_Node, N_Function_Instantiation, - N_Procedure_Instantiation, - N_Subprogram_Body) + and then Nkind (Unit_Node) in N_Function_Instantiation + | N_Procedure_Instantiation + | N_Subprogram_Body then declare Spec : Node_Id; @@ -1190,10 +1190,10 @@ package body Sem_Ch10 is -- units manufactured by the compiler never need elab checks. if Comes_From_Source (N) - and then Nkind_In (Unit_Node, N_Package_Declaration, - N_Generic_Package_Declaration, - N_Subprogram_Declaration, - N_Generic_Subprogram_Declaration) + and then Nkind (Unit_Node) in N_Package_Declaration + | N_Generic_Package_Declaration + | N_Subprogram_Declaration + | N_Generic_Subprogram_Declaration then declare Loc : constant Source_Ptr := Sloc (N); @@ -1478,10 +1478,10 @@ package body Sem_Ch10 is -- Verify that the illegal contexts given in 10.1.2 (18/2) are -- properly rejected, including renaming declarations. - if not Nkind_In (Ukind, N_Package_Declaration, - N_Subprogram_Declaration) - and then Ukind not in N_Generic_Declaration - and then Ukind not in N_Generic_Instantiation + if Ukind not in N_Package_Declaration + | N_Subprogram_Declaration + | N_Generic_Declaration + | N_Generic_Instantiation then Error_Msg_N ("limited with_clause not allowed here", Item); @@ -1536,10 +1536,9 @@ package body Sem_Ch10 is if Item /= It and then Nkind (It) = N_With_Clause and then not Limited_Present (It) - and then - Nkind_In (Unit (Library_Unit (It)), - N_Package_Declaration, - N_Package_Renaming_Declaration) + and then Nkind (Unit (Library_Unit (It))) in + N_Package_Declaration | + N_Package_Renaming_Declaration then if Nkind (Unit (Library_Unit (It))) = N_Package_Declaration @@ -2022,9 +2021,8 @@ package body Sem_Ch10 is -- Verify that the identifier for the stub is unique within this -- declarative part. - if Nkind_In (Parent (N), N_Block_Statement, - N_Package_Body, - N_Subprogram_Body) + if Nkind (Parent (N)) in + N_Block_Statement | N_Package_Body | N_Subprogram_Body then Decl := First (Declarations (Parent (N))); while Present (Decl) and then Decl /= N loop @@ -2361,8 +2359,7 @@ package body Sem_Ch10 is Remove_Scope; end if; - if Nkind_In (Unit (Lib_Spec), N_Package_Body, - N_Subprogram_Body) + if Nkind (Unit (Lib_Spec)) in N_Package_Body | N_Subprogram_Body then Remove_Context (Library_Unit (Lib_Spec)); end if; @@ -2655,9 +2652,8 @@ package body Sem_Ch10 is if Nkind (Nam) = N_Selected_Component and then Nkind (Prefix (Nam)) = N_Identifier and then Chars (Prefix (Nam)) = Name_Gnat - and then Nam_In (Chars (Selector_Name (Nam)), - Name_Most_Recent_Exception, - Name_Exception_Traces) + and then Chars (Selector_Name (Nam)) + in Name_Most_Recent_Exception | Name_Exception_Traces then Check_Restriction (No_Exception_Propagation, N); Special_Exception_Package_Used := True; @@ -2967,7 +2963,7 @@ package body Sem_Ch10 is -- Start of processing for Check_Private_Child_Unit begin - if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then + if Nkind (Lib_Unit) in N_Package_Body | N_Subprogram_Body then Curr_Unit := Defining_Entity (Unit (Library_Unit (N))); Par_Lib := Curr_Unit; @@ -3074,7 +3070,7 @@ package body Sem_Ch10 is elsif Curr_Private or else Private_Present (Item) - or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit) + or else Nkind (Lib_Unit) in N_Package_Body | N_Subunit or else (Nkind (Lib_Unit) = N_Subprogram_Body and then not Acts_As_Spec (Parent (Lib_Unit))) then @@ -3101,11 +3097,9 @@ package body Sem_Ch10 is Kind : constant Node_Kind := Nkind (Par); begin - if Nkind_In (Kind, N_Package_Body, - N_Subprogram_Body, - N_Task_Body, - N_Protected_Body) - and then Nkind_In (Parent (Par), N_Compilation_Unit, N_Subunit) + if Kind in + N_Package_Body | N_Subprogram_Body | N_Task_Body | N_Protected_Body + and then Nkind (Parent (Par)) in N_Compilation_Unit | N_Subunit then null; @@ -3202,11 +3196,11 @@ package body Sem_Ch10 is -- on a child unit implies that the implicit with on the parent is also -- private. - if Nkind_In (Unit (N), N_Generic_Package_Declaration, - N_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration, - N_Subprogram_Body) + if Nkind (Unit (N)) in N_Generic_Package_Declaration + | N_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Subprogram_Declaration + | N_Subprogram_Body then Set_Private_Present (Withn, Private_Present (Item)); end if; @@ -3715,10 +3709,10 @@ package body Sem_Ch10 is Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N); end if; - if Nkind_In (Lib_Unit, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Declaration) + if Nkind (Lib_Unit) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Subprogram_Declaration then if Is_Child_Spec (Lib_Unit) then Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit))); @@ -3908,9 +3902,8 @@ package body Sem_Ch10 is elsif Private_Present (Parent (Item)) or else Curr_Private or else Private_Present (Item) - or else Nkind_In (Unit (Parent (Item)), N_Package_Body, - N_Subprogram_Body, - N_Subunit) + or else Nkind (Unit (Parent (Item))) in + N_Package_Body | N_Subprogram_Body | N_Subunit then -- Current unit is private, of descendant of a private unit @@ -4068,9 +4061,8 @@ package body Sem_Ch10 is then if not Private_Present (Item) or else Private_Present (N) - or else Nkind_In (Unit (N), N_Package_Body, - N_Subprogram_Body, - N_Subunit) + or else Nkind (Unit (N)) in + N_Package_Body | N_Subprogram_Body | N_Subunit then Install_Limited_With_Clause (Item); end if; @@ -4162,9 +4154,9 @@ package body Sem_Ch10 is end if; if Ekind (P_Name) = E_Generic_Package - and then not Nkind_In (Lib_Unit, N_Generic_Subprogram_Declaration, - N_Generic_Package_Declaration) - and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration + and then Nkind (Lib_Unit) not in N_Generic_Subprogram_Declaration + | N_Generic_Package_Declaration + | N_Generic_Renaming_Declaration then Error_Msg_N ("child of a generic package must be a generic unit", Lib_Unit); @@ -4627,17 +4619,17 @@ package body Sem_Ch10 is -- Save for subsequent examination of import pragmas. if Comes_From_Source (Decl) - and then (Nkind_In (Decl, N_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration, - N_Generic_Subprogram_Declaration)) + and then (Nkind (Decl) in N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration + | N_Generic_Subprogram_Declaration) then Append_Elmt (Defining_Entity (Decl), Subp_List); -- Package declaration of generic package declaration. We need -- to recursively examine nested declarations. - elsif Nkind_In (Decl, N_Package_Declaration, - N_Generic_Package_Declaration) + elsif Nkind (Decl) in N_Package_Declaration + | N_Generic_Package_Declaration then Check_Declarations (Specification (Decl)); @@ -4657,14 +4649,14 @@ package body Sem_Ch10 is Decl := First (Private_Declarations (Spec)); while Present (Decl) loop if Comes_From_Source (Decl) - and then (Nkind_In (Decl, N_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration, - N_Generic_Subprogram_Declaration)) + and then Nkind (Decl) in N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration + | N_Generic_Subprogram_Declaration then Append_Elmt (Defining_Entity (Decl), Subp_List); - elsif Nkind_In (Decl, N_Package_Declaration, - N_Generic_Package_Declaration) + elsif Nkind (Decl) in N_Package_Declaration + | N_Generic_Package_Declaration then Check_Declarations (Specification (Decl)); @@ -4899,8 +4891,8 @@ package body Sem_Ch10 is -- corresponding spec, otherwise follow pointer to parent spec. if Present (Library_Unit (Aux_Unit)) - and then Nkind_In (Unit (Aux_Unit), - N_Package_Body, N_Subprogram_Body) + and then Nkind (Unit (Aux_Unit)) in + N_Package_Body | N_Subprogram_Body then if Aux_Unit = Library_Unit (Aux_Unit) then @@ -5551,7 +5543,7 @@ package body Sem_Ch10 is E1 : constant Entity_Id := Defining_Entity (Unit (U1)); E2 : Entity_Id; begin - if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then + if Nkind (Unit (U2)) in N_Package_Body | N_Subprogram_Body then E2 := Defining_Entity (Unit (Library_Unit (U2))); return Is_Ancestor_Package (E1, E2); else @@ -6058,12 +6050,12 @@ package body Sem_Ch10 is -- Types - elsif Nkind_In (Decl, N_Full_Type_Declaration, - N_Incomplete_Type_Declaration, - N_Private_Extension_Declaration, - N_Private_Type_Declaration, - N_Protected_Type_Declaration, - N_Task_Type_Declaration) + elsif Nkind (Decl) in N_Full_Type_Declaration + | N_Incomplete_Type_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Protected_Type_Declaration + | N_Task_Type_Declaration then Def_Id := Defining_Entity (Decl); @@ -6082,8 +6074,8 @@ package body Sem_Ch10 is (Nkind (Def) = N_Derived_Type_Definition and then Present (Record_Extension_Part (Def))); - elsif Nkind_In (Decl, N_Incomplete_Type_Declaration, - N_Private_Type_Declaration) + elsif Nkind (Decl) in N_Incomplete_Type_Declaration + | N_Private_Type_Declaration then Is_Tagged := Tagged_Present (Decl); @@ -6365,7 +6357,7 @@ package body Sem_Ch10 is then Set_Body_Needed_For_SAL (Unit_Name); - elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then + elsif Ekind (Unit_Name) in E_Generic_Procedure | E_Generic_Function then Set_Body_Needed_For_SAL (Unit_Name); elsif Is_Subprogram (Unit_Name) diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index ea7f364..940c93b 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -433,7 +433,7 @@ package body Sem_Ch11 is if ((Is_Subprogram (Current_Scope) or else Is_Entry (Current_Scope)) and then Chars (Current_Scope) /= Name_uPostconditions) - or else Ekind_In (Current_Scope, E_Block, E_Task_Type) + or else Ekind (Current_Scope) in E_Block | E_Task_Type then Warn_On_Useless_Assignments (Current_Scope); end if; @@ -537,7 +537,7 @@ package body Sem_Ch11 is -- Skip past null statements and pragmas while Present (P) - and then Nkind_In (P, N_Null_Statement, N_Pragma) + and then Nkind (P) in N_Null_Statement | N_Pragma loop P := Prev (P); end loop; @@ -594,11 +594,9 @@ package body Sem_Ch11 is if No (Exception_Id) then P := Parent (N); - while not Nkind_In (P, N_Exception_Handler, - N_Subprogram_Body, - N_Package_Body, - N_Task_Body, - N_Entry_Body) + while Nkind (P) not in + N_Exception_Handler | N_Subprogram_Body | N_Package_Body | + N_Task_Body | N_Entry_Body loop P := Parent (P); end loop; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4307111..cbf27e2 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1573,9 +1573,9 @@ package body Sem_Ch12 is (Defining_Unit_Name (Specification (Analyzed_Formal))); when N_Formal_Package_Declaration => - exit when Nkind_In (Kind, N_Formal_Package_Declaration, - N_Generic_Package_Declaration, - N_Package_Declaration); + exit when Kind in N_Formal_Package_Declaration + | N_Generic_Package_Declaration + | N_Package_Declaration; when N_Use_Package_Clause | N_Use_Type_Clause @@ -1589,10 +1589,10 @@ package body Sem_Ch12 is exit when Kind not in N_Formal_Subprogram_Declaration - and then not Nkind_In (Kind, N_Subprogram_Declaration, - N_Freeze_Entity, - N_Null_Statement, - N_Itype_Reference) + and then Kind not in N_Subprogram_Declaration + | N_Freeze_Entity + | N_Null_Statement + | N_Itype_Reference and then Chars (Defining_Identifier (Formal)) = Chars (Defining_Identifier (Analyzed_Formal)); end case; @@ -2103,10 +2103,10 @@ package body Sem_Ch12 is S := Current_Scope; while Present (S) loop - if Ekind_In (S, E_Block, - E_Function, - E_Loop, - E_Procedure) + if Ekind (S) in E_Block + | E_Function + | E_Loop + | E_Procedure then Needs_Freezing := False; exit; @@ -2250,9 +2250,9 @@ package body Sem_Ch12 is if Nkind (Def) = N_Constrained_Array_Definition then DSS := First (Discrete_Subtype_Definitions (Def)); while Present (DSS) loop - if Nkind_In (DSS, N_Subtype_Indication, - N_Range, - N_Attribute_Reference) + if Nkind (DSS) in N_Subtype_Indication + | N_Range + | N_Attribute_Reference then Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); end if; @@ -5032,7 +5032,7 @@ package body Sem_Ch12 is while Present (S) and then S /= Standard_Standard loop if Is_Generic_Instance (S) and then (In_Package_Body (S) - or else Ekind_In (S, E_Procedure, E_Function)) + or else Ekind (S) in E_Procedure | E_Function) then -- We still have to remove the entities of the enclosing -- instance from direct visibility. @@ -5201,7 +5201,7 @@ package body Sem_Ch12 is Set_Is_Generic_Instance (Inst, True); if In_Package_Body (Inst) - or else Ekind_In (S, E_Procedure, E_Function) + or else Ekind (S) in E_Procedure | E_Function then E := First_Entity (Instances (J)); while Present (E) loop @@ -5974,7 +5974,7 @@ package body Sem_Ch12 is if Nkind (Assoc) /= Nkind (N) then return Assoc; - elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then + elsif Nkind (Assoc) in N_Aggregate | N_Extension_Aggregate then return Assoc; else @@ -5994,11 +5994,11 @@ package body Sem_Ch12 is if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) and then Present (Associated_Node (Assoc)) - and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, - N_Explicit_Dereference, - N_Integer_Literal, - N_Real_Literal, - N_String_Literal)) + and then Nkind (Associated_Node (Assoc)) in N_Function_Call + | N_Explicit_Dereference + | N_Integer_Literal + | N_Real_Literal + | N_String_Literal then Assoc := Associated_Node (Assoc); end if; @@ -6506,9 +6506,9 @@ package body Sem_Ch12 is if Kind = N_Formal_Type_Declaration then return; - elsif Nkind_In (Kind, N_Formal_Object_Declaration, - N_Formal_Package_Declaration) - or else Kind in N_Formal_Subprogram_Declaration + elsif Kind in N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Subprogram_Declaration then null; @@ -6701,9 +6701,8 @@ package body Sem_Ch12 is -- If the formal entity comes from a formal declaration, it was -- defaulted in the formal package, and no check is needed on it. - elsif Nkind_In (Original_Node (Parent (E2)), - N_Formal_Object_Declaration, - N_Formal_Type_Declaration) + elsif Nkind (Original_Node (Parent (E2))) in + N_Formal_Object_Declaration | N_Formal_Type_Declaration then -- If the formal is a tagged type the corresponding class-wide -- type has been generated as well, and it must be skipped. @@ -7958,11 +7957,11 @@ package body Sem_Ch12 is -- Special casing for identifiers and other entity names and operators - if Nkind_In (New_N, N_Character_Literal, - N_Expanded_Name, - N_Identifier, - N_Operator_Symbol) - or else Nkind (New_N) in N_Op + if Nkind (New_N) in N_Character_Literal + | N_Expanded_Name + | N_Identifier + | N_Operator_Symbol + | N_Op then if not Instantiating then @@ -8006,10 +8005,9 @@ package body Sem_Ch12 is end if; elsif No (Ent) - or else - not Nkind_In (Ent, N_Defining_Identifier, - N_Defining_Character_Literal, - N_Defining_Operator_Symbol) + or else Nkind (Ent) not in N_Defining_Identifier + | N_Defining_Character_Literal + | N_Defining_Operator_Symbol or else No (Scope (Ent)) or else (Scope (Ent) = Current_Instantiated_Parent.Gen_Id @@ -8176,9 +8174,9 @@ package body Sem_Ch12 is then Set_Entity (New_N, Entity (Name (Assoc))); - elsif Nkind_In (Assoc, N_Defining_Identifier, - N_Defining_Character_Literal, - N_Defining_Operator_Symbol) + elsif Nkind (Assoc) in N_Defining_Identifier + | N_Defining_Character_Literal + | N_Defining_Operator_Symbol and then Expander_Active then -- Inlining case: we are copying a tree that contains @@ -8387,7 +8385,7 @@ package body Sem_Ch12 is Set_Assignment_OK (Name (New_N), True); end if; - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then if not Instantiating then Set_Associated_Node (N, New_N); @@ -8507,7 +8505,7 @@ package body Sem_Ch12 is -- Do not copy Comment or Ident pragmas their content is relevant to -- the generic unit, not to the instantiating unit. - if Nam_In (Pragma_Name_Unmapped (N), Name_Comment, Name_Ident) then + if Pragma_Name_Unmapped (N) in Name_Comment | Name_Ident then New_N := Make_Null_Statement (Sloc (N)); -- Do not copy pragmas generated from aspects because the pragmas do @@ -8527,7 +8525,7 @@ package body Sem_Ch12 is Copy_Descendants; end if; - elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then + elsif Nkind (N) in N_Integer_Literal | N_Real_Literal then -- No descendant fields need traversing @@ -9226,10 +9224,10 @@ package body Sem_Ch12 is else Inst := Next (Decl); - while not Nkind_In (Inst, N_Formal_Package_Declaration, - N_Function_Instantiation, - N_Package_Instantiation, - N_Procedure_Instantiation) + while Nkind (Inst) not in N_Formal_Package_Declaration + | N_Function_Instantiation + | N_Package_Instantiation + | N_Procedure_Instantiation loop Next (Inst); end loop; @@ -9522,7 +9520,7 @@ package body Sem_Ch12 is while Present (P) and then Nkind (Parent (P)) /= N_Compilation_Unit loop - if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then + if Nkind (P) in N_Package_Body | N_Subprogram_Body then if Nkind (Parent (P)) = N_Subunit then return Corresponding_Stub (Parent (P)); else @@ -9620,8 +9618,8 @@ package body Sem_Ch12 is -- the current scope as well. elsif Present (Next (N)) - and then Nkind_In (Next (N), N_Subprogram_Body, - N_Package_Body) + and then Nkind (Next (N)) in N_Subprogram_Body + | N_Package_Body and then Comes_From_Source (Next (N)) then null; @@ -9835,8 +9833,8 @@ package body Sem_Ch12 is Must_Delay := (Gen_Unit = Act_Unit - and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration, - N_Package_Declaration) + and then (Nkind (Gen_Unit) in N_Generic_Package_Declaration + | N_Package_Declaration or else (Gen_Unit = Body_Unit and then True_Sloc (N, Act_Unit) < Sloc (Orig_Body))) @@ -9907,7 +9905,7 @@ package body Sem_Ch12 is -- Freeze package enclosing instance of inner generic after -- instance of enclosing generic. - elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) + elsif Nkind (Parent (N)) in N_Package_Body | N_Subprogram_Body and then In_Same_Declarative_Part (Parent (Freeze_Node (Par)), Parent (N)) then @@ -10910,10 +10908,10 @@ package body Sem_Ch12 is end if; if (Present (Act_E) and then Is_Overloadable (Act_E)) - or else Nkind_In (Act, N_Attribute_Reference, - N_Indexed_Component, - N_Character_Literal, - N_Explicit_Dereference) + or else Nkind (Act) in N_Attribute_Reference + | N_Indexed_Component + | N_Character_Literal + | N_Explicit_Dereference then return; end if; @@ -11012,10 +11010,10 @@ package body Sem_Ch12 is Nam := Actual; elsif Present (Default_Name (Formal)) then - if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, - N_Selected_Component, - N_Indexed_Component, - N_Character_Literal) + if Nkind (Default_Name (Formal)) not in N_Attribute_Reference + | N_Selected_Component + | N_Indexed_Component + | N_Character_Literal and then Present (Entity (Default_Name (Formal))) then Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); @@ -11588,8 +11586,8 @@ package body Sem_Ch12 is if Ada_Version >= Ada_2005 and then Present (Actual_Decl) - and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, - N_Object_Declaration) + and then Nkind (Actual_Decl) in N_Formal_Object_Declaration + | N_Object_Declaration and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration and then not Has_Null_Exclusion (Actual_Decl) and then Has_Null_Exclusion (Analyzed_Formal) @@ -12029,6 +12027,19 @@ package body Sem_Ch12 is end if; Restore_Hidden_Primitives (Vis_Prims_List); + + -- Restore the private views that were made visible when the body of + -- the instantiation was created. Note that, in the case where one of + -- these private views is declared in the parent, there is a nesting + -- issue with the calls to Install_Parent and Remove_Parent made in + -- between above with In_Body set to True, because these calls also + -- want to swap and restore this private view respectively. In this + -- case, the call to Install_Parent does nothing, but the call to + -- Remove_Parent does restore the private view, thus undercutting the + -- call to Restore_Private_Views. That's OK under the condition that + -- the two mechanisms swap exactly the same entities, in particular + -- the private entities dependent on the primary private entities. + Restore_Private_Views (Act_Decl_Id); -- Remove the current unit from visibility if this is an instance @@ -12639,8 +12650,8 @@ package body Sem_Ch12 is Root_Type (Act_T))) or else - (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Type) + (Ekind (Gen_T) in E_Anonymous_Access_Subprogram_Type + | E_Anonymous_Access_Type and then Ekind (Act_T) = Ekind (Gen_T) and then Subtypes_Statically_Match (Designated_Type (Gen_T), Designated_Type (Act_T))); @@ -14039,8 +14050,8 @@ package body Sem_Ch12 is Set_Generic_Parent_Type (Decl_Node, Ancestor); end if; - elsif Nkind_In (Def, N_Formal_Private_Type_Definition, - N_Formal_Incomplete_Type_Definition) + elsif Nkind (Def) in N_Formal_Private_Type_Definition + | N_Formal_Incomplete_Type_Definition then Set_Generic_Parent_Type (Decl_Node, A_Gen_T); end if; @@ -14191,8 +14202,8 @@ package body Sem_Ch12 is -- For a subprogram instantiation, omit instantiations intrinsic -- operations (Unchecked_Conversions, etc.) that have no bodies. - elsif Nkind_In (Decl, N_Function_Instantiation, - N_Procedure_Instantiation) + elsif Nkind (Decl) in N_Function_Instantiation + | N_Procedure_Instantiation and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) then Append_Elmt (Decl, Previous_Instances); @@ -14292,6 +14303,21 @@ package body Sem_Ch12 is exit; + -- If an ancestor of the generic comes from a formal package + -- there is no source for the ancestor body. This is detected + -- by examining the scope of the ancestor and its declaration. + -- The body, if any is needed, will be available when the + -- current unit (containing a formal package) is instantiated. + + elsif Nkind (True_Parent) = N_Package_Specification + and then Present (Generic_Parent (True_Parent)) + and then Nkind + (Original_Node (Unit_Declaration_Node + (Scope (Generic_Parent (True_Parent))))) + = N_Formal_Package_Declaration + then + return; + else True_Parent := Parent (True_Parent); end if; @@ -14419,10 +14445,10 @@ package body Sem_Ch12 is (Last (Visible_Declarations (Specification (Info.Act_Decl)))); begin - while Nkind_In (Decl, - N_Null_Statement, - N_Pragma, - N_Subprogram_Renaming_Declaration) + while Nkind (Decl) in + N_Null_Statement | + N_Pragma | + N_Subprogram_Renaming_Declaration loop Decl := Prev (Decl); end loop; @@ -15141,9 +15167,9 @@ package body Sem_Ch12 is -- explicitly now, in order to remain consistent with the view of the -- parent type. - if Ekind_In (Typ, E_Private_Type, - E_Limited_Private_Type, - E_Record_Type_With_Private) + if Ekind (Typ) in E_Private_Type + | E_Limited_Private_Type + | E_Record_Type_With_Private then Dep_Elmt := First_Elmt (Private_Dependents (Typ)); while Present (Dep_Elmt) loop @@ -15630,9 +15656,9 @@ package body Sem_Ch12 is -- preserve in this case, since the expansion will be redone in -- the instance. - if not Nkind_In (E, N_Defining_Character_Literal, - N_Defining_Identifier, - N_Defining_Operator_Symbol) + if Nkind (E) not in N_Defining_Character_Literal + | N_Defining_Identifier + | N_Defining_Operator_Symbol then Set_Associated_Node (N, Empty); Set_Etype (N, Empty); @@ -15723,7 +15749,7 @@ package body Sem_Ch12 is -- its value. Otherwise the folding will happen in any instantiation. elsif Nkind (Parent (N)) = N_Selected_Component - and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) + and then Nkind (Parent (N2)) in N_Integer_Literal | N_Real_Literal then if Present (Entity (Original_Node (Parent (N2)))) and then Is_Global (Entity (Original_Node (Parent (N2)))) @@ -16025,12 +16051,12 @@ package body Sem_Ch12 is -- global references within their aspects due to the timing of -- annotation analysis. - if Nkind_In (Nod, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Body, - N_Package_Body_Stub, - N_Subprogram_Body, - N_Subprogram_Body_Stub) + if Nkind (Nod) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Body + | N_Package_Body_Stub + | N_Subprogram_Body + | N_Subprogram_Body_Stub then -- Since the capture of global references is done on the -- unanalyzed generic template, there is no information around @@ -16220,7 +16246,7 @@ package body Sem_Ch12 is -- constant folding which will be repeated in the instance. -- Is this still needed??? - elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) + elsif Nkind (N2) in N_Integer_Literal | N_Real_Literal and then Is_Entity_Name (Original_Node (N2)) then Set_Associated_Node (N, Original_Node (N2)); @@ -16322,9 +16348,9 @@ package body Sem_Ch12 is -- The operator was folded into a literal - elsif Nkind_In (N2, N_Integer_Literal, - N_Real_Literal, - N_String_Literal) + elsif Nkind (N2) in N_Integer_Literal + | N_Real_Literal + | N_String_Literal then if Present (Original_Node (N2)) and then Nkind (Original_Node (N2)) = Nkind (N) @@ -16434,12 +16460,12 @@ package body Sem_Ch12 is -- Aggregates - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then Save_References_In_Aggregate (N); -- Character literals, operator symbols - elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then + elsif Nkind (N) in N_Character_Literal | N_Operator_Symbol then Save_References_In_Char_Lit_Or_Op_Symbol (N); -- Defining identifiers @@ -16665,19 +16691,9 @@ package body Sem_Ch12 is end if; while Present (Priv_Elmt) loop - Priv_Sub := (Node (Priv_Elmt)); - - -- We avoid flipping the subtype if the Etype of its full view is - -- private because this would result in a malformed subtype. This - -- occurs when the Etype of the subtype full view is the full view of - -- the base type (and since the base types were just switched, the - -- subtype is pointing to the wrong view). This is currently the case - -- for tagged record types, access types (maybe more?) and needs to - -- be resolved. ??? - - if Present (Full_View (Priv_Sub)) - and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) - then + Priv_Sub := Node (Priv_Elmt); + + if Present (Full_View (Priv_Sub)) then Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); Exchange_Declarations (Priv_Sub); end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 4bdd2cf..30cade8 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -985,7 +985,7 @@ package body Sem_Ch13 is function Find_Type (N : Node_Id) return Traverse_Result is begin if N = Typ - or else (Nkind_In (N, N_Identifier, N_Expanded_Name) + or else (Nkind (N) in N_Identifier | N_Expanded_Name and then Present (Entity (N)) and then Entity (N) = Typ) then @@ -1034,7 +1034,8 @@ package body Sem_Ch13 is and then Has_Primitive_Operations (Parent_Type) then Error_Msg_N - ("|representation aspect not permitted before Ada 202x!", N); + ("|representation aspect not permitted before Ada 202x: " & + "use -gnat2020!", N); Error_Msg_NE ("\parent type & has primitive operations!", N, Parent_Type); @@ -1586,11 +1587,11 @@ package body Sem_Ch13 is -- package body Pack is -- pragma Prag; - if Nkind_In (N, N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + if Nkind (N) in N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body then Decls := Declarations (N); @@ -1610,8 +1611,8 @@ package body Sem_Ch13 is -- package Pack is -- pragma Prag; - elsif Nkind_In (N, N_Generic_Package_Declaration, - N_Package_Declaration) + elsif Nkind (N) in N_Generic_Package_Declaration + | N_Package_Declaration then Decls := Visible_Declarations (Specification (N)); @@ -2097,10 +2098,9 @@ package body Sem_Ch13 is begin while Present (Disc) loop if Chars (Expr) = Chars (Disc) - and then Ekind_In - (Etype (Disc), - E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Type) + and then Ekind (Etype (Disc)) in + E_Anonymous_Access_Subprogram_Type | + E_Anonymous_Access_Type then Set_Has_Implicit_Dereference (E); Set_Has_Implicit_Dereference (Disc); @@ -2168,7 +2168,7 @@ package body Sem_Ch13 is begin -- The relaxed parameter is a formal parameter - if Nkind_In (Param, N_Identifier, N_Expanded_Name) then + if Nkind (Param) in N_Identifier | N_Expanded_Name then Analyze (Param); declare @@ -2202,7 +2202,7 @@ package body Sem_Ch13 is begin if Present (Pref) and then - Nkind_In (Pref, N_Identifier, N_Expanded_Name) + Nkind (Pref) in N_Identifier | N_Expanded_Name and then Entity (Pref) = Subp_Id then @@ -2405,6 +2405,35 @@ package body Sem_Ch13 is --------------------------- procedure Analyze_Aspect_Static is + function Has_Convention_Intrinsic (L : List_Id) return Boolean; + -- Return True if L contains a pragma argument association + -- node representing a convention Intrinsic. + + ------------------------------ + -- Has_Convention_Intrinsic -- + ------------------------------ + + function Has_Convention_Intrinsic + (L : List_Id) return Boolean + is + Arg : Node_Id := First (L); + begin + while Present (Arg) loop + if Nkind (Arg) = N_Pragma_Argument_Association + and then Chars (Arg) = Name_Convention + and then Chars (Expression (Arg)) = Name_Intrinsic + then + return True; + end if; + + Next (Arg); + end loop; + + return False; + end Has_Convention_Intrinsic; + + Is_Imported_Intrinsic : Boolean; + begin if Ada_Version < Ada_2020 then Error_Msg_N @@ -2412,21 +2441,44 @@ package body Sem_Ch13 is Error_Msg_N ("\compile with -gnat2020", Aspect); return; + end if; + + Is_Imported_Intrinsic := Is_Imported (E) + and then + Has_Convention_Intrinsic + (Pragma_Argument_Associations (Import_Pragma (E))); -- The aspect applies only to expression functions that -- statisfy the requirements for a static expression function - -- (such as having an expression that is predicate-static). + -- (such as having an expression that is predicate-static) as + -- well as Intrinsic imported functions as a -gnatX extension. - elsif not Is_Expression_Function (E) then - Error_Msg_N - ("aspect % requires expression function", Aspect); + if not Is_Expression_Function (E) + and then + not (Extensions_Allowed and then Is_Imported_Intrinsic) + then + if Extensions_Allowed then + Error_Msg_N + ("aspect % requires intrinsic or expression function", + Aspect); + + elsif Is_Imported_Intrinsic then + Error_Msg_N + ("aspect % on intrinsic function is an extension: " & + "use -gnatX", + Aspect); + + else + Error_Msg_N + ("aspect % requires expression function", Aspect); + end if; return; -- Ada 202x (AI12-0075): Check that the function satisfies - -- several requirements of static expression functions as - -- specified in RM 6.8(5.1-5.8). Note that some of the - -- requirements given there are checked elsewhere. + -- several requirements of static functions as specified in + -- RM 6.8(5.1-5.8). Note that some of the requirements given + -- there are checked elsewhere. else -- The expression of the expression function must be a @@ -2533,11 +2585,11 @@ package body Sem_Ch13 is begin -- Check valid declarations for 'Yield - if (Nkind_In (N, N_Abstract_Subprogram_Declaration, - N_Entry_Declaration, - N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) - or else Nkind (N) in N_Formal_Subprogram_Declaration) + if Nkind (N) in N_Abstract_Subprogram_Declaration + | N_Entry_Declaration + | N_Generic_Subprogram_Declaration + | N_Subprogram_Declaration + | N_Formal_Subprogram_Declaration and then not Within_Protected_Type (E) then null; @@ -2809,17 +2861,30 @@ package body Sem_Ch13 is if A_Id in Boolean_Aspects and then No (Expr) then Delay_Required := False; - -- For non-Boolean aspects, don't delay if integer literal, - -- unless the aspect is Alignment, which affects the - -- freezing of an initialized object. + -- For non-Boolean aspects, don't delay if integer literal elsif A_Id not in Boolean_Aspects - and then A_Id /= Aspect_Alignment and then Present (Expr) and then Nkind (Expr) = N_Integer_Literal then Delay_Required := False; + -- For Alignment and various Size aspects, don't delay for + -- an attribute reference whose prefix is Standard, for + -- example Standard'Maximum_Alignment or Standard'Word_Size. + + elsif (A_Id = Aspect_Alignment + or else A_Id = Aspect_Component_Size + or else A_Id = Aspect_Object_Size + or else A_Id = Aspect_Size + or else A_Id = Aspect_Value_Size) + and then Present (Expr) + and then Nkind (Expr) = N_Attribute_Reference + and then Nkind (Prefix (Expr)) = N_Identifier + and then Chars (Prefix (Expr)) = Name_Standard + then + Delay_Required := False; + -- All other cases are delayed else @@ -3177,8 +3242,7 @@ package body Sem_Ch13 is | Aspect_Interrupt_Priority | Aspect_Priority => - if Nkind_In (N, N_Subprogram_Body, - N_Subprogram_Declaration) + if Nkind (N) in N_Subprogram_Body | N_Subprogram_Declaration then -- Analyze the aspect expression @@ -3368,8 +3432,8 @@ package body Sem_Ch13 is Context := Instance_Spec (Context); end if; - if Nkind_In (Context, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (Context) in N_Generic_Package_Declaration + | N_Package_Declaration then Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( @@ -3595,8 +3659,8 @@ package body Sem_Ch13 is Context := Instance_Spec (Context); end if; - if Nkind_In (Context, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (Context) in N_Generic_Package_Declaration + | N_Package_Declaration then Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( @@ -3643,8 +3707,8 @@ package body Sem_Ch13 is Context := Instance_Spec (Context); end if; - if Nkind_In (Context, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (Context) in N_Generic_Package_Declaration + | N_Package_Declaration then Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( @@ -3745,8 +3809,8 @@ package body Sem_Ch13 is -- Part_Of when Aspect_Part_Of => - if Nkind_In (N, N_Object_Declaration, - N_Package_Instantiation) + if Nkind (N) in N_Object_Declaration + | N_Package_Instantiation or else Is_Single_Concurrent_Type_Declaration (N) then Make_Aitem_Pragma @@ -4138,7 +4202,7 @@ package body Sem_Ch13 is if Class_Present (Aspect) and then Is_Concurrent_Type (Current_Scope) - and then Ekind_In (E, E_Entry, E_Function, E_Procedure) + and then Ekind (E) in E_Entry | E_Function | E_Procedure then Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Aspect); Error_Msg_N @@ -4383,8 +4447,8 @@ package body Sem_Ch13 is if A_Id in Library_Unit_Aspects and then - Nkind_In (N, N_Package_Declaration, - N_Generic_Package_Declaration) + Nkind (N) in N_Package_Declaration + | N_Generic_Package_Declaration and then Nkind (Parent (N)) /= N_Compilation_Unit -- Aspect is legal on a local instantiation of a library- @@ -4606,7 +4670,7 @@ package body Sem_Ch13 is -- When delay is not required and the context is a package or a -- subprogram body, insert the pragma in the body declarations. - elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then + elsif Nkind (N) in N_Package_Body | N_Subprogram_Body then if No (Declarations (N)) then Set_Declarations (N, New_List); end if; @@ -5422,7 +5486,7 @@ package body Sem_Ch13 is end if; end if; - -- All checks succeeded. + -- All checks succeeded Indexing_Found := True; end Check_One_Function; @@ -5934,7 +5998,7 @@ package body Sem_Ch13 is if Ignore_Rep_Clauses then Set_Address_Taken (U_Ent); - if Ekind_In (U_Ent, E_Variable, E_Constant) then + if Ekind (U_Ent) in E_Variable | E_Constant then Record_Rep_Item (U_Ent, N); end if; @@ -6013,7 +6077,7 @@ package body Sem_Ch13 is -- Case of address clause for an object - elsif Ekind_In (U_Ent, E_Constant, E_Variable) then + elsif Ekind (U_Ent) in E_Constant | E_Variable then declare Expr : constant Node_Id := Expression (N); O_Ent : Entity_Id; @@ -6124,9 +6188,13 @@ package body Sem_Ch13 is -- Issue an unconditional warning for a constant overlaying -- a variable. For the reverse case, we will issue it only -- if the variable is modified. + -- Within a generic unit an In_Parameter is a constant. + -- It can be instantiated with a variable, in which case + -- there will be a warning on the instance. if Ekind (U_Ent) = E_Constant and then Present (O_Ent) + and then Ekind (O_Ent) /= E_Generic_In_Parameter and then not Overlays_Constant (U_Ent) and then Address_Clause_Overlay_Warnings then @@ -6376,37 +6444,48 @@ package body Sem_Ch13 is --------- when Attribute_CPU => + pragma Assert (From_Aspect_Specification (N)); + -- The parser forbids this clause in source code, so it must have + -- come from an aspect specification. - -- CPU attribute definition clause not allowed except from aspect - -- specification. - - if From_Aspect_Specification (N) then - if not Is_Task_Type (U_Ent) then - Error_Msg_N ("CPU can only be defined for task", Nam); - - elsif Duplicate_Clause then - null; - - else - -- The expression must be analyzed in the special manner - -- described in "Handling of Default and Per-Object - -- Expressions" in sem.ads. + if not Is_Task_Type (U_Ent) then + Error_Msg_N ("CPU can only be defined for task", Nam); - -- The visibility to the components must be established - -- and restored before and after analysis. + elsif Duplicate_Clause then + null; - Push_Type (U_Ent); - Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); - Pop_Type (U_Ent); + else + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + -- The visibility to the components must be established + -- and restored before and after analysis. + + Push_Type (U_Ent); + Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); + Pop_Type (U_Ent); + + -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU": + -- If the expression is static, and its value is + -- System.Multiprocessors.Not_A_Specific_CPU (i.e. zero) then + -- that's a violation of No_Tasks_Unassigned_To_CPU. It might + -- seem better to refer to Not_A_Specific_CPU here, but that + -- involves a lot of horsing around with Rtsfind, and this + -- value is not going to change, so it's better to hardwire + -- Uint_0. + -- + -- AI12-0055-1, "All properties of a usage profile are defined + -- by pragmas": If the expression is nonstatic, that's a + -- violation of No_Dynamic_CPU_Assignment. - if not Is_OK_Static_Expression (Expr) then - Check_Restriction (Static_Priorities, Expr); + if Is_OK_Static_Expression (Expr) then + if Expr_Value (Expr) = Uint_0 then + Check_Restriction (No_Tasks_Unassigned_To_CPU, Expr); end if; + else + Check_Restriction (No_Dynamic_CPU_Assignment, Expr); end if; - - else - Error_Msg_N - ("attribute& cannot be set with definition clause", N); end if; ---------------------- @@ -6470,36 +6549,30 @@ package body Sem_Ch13 is ------------------------ when Attribute_Dispatching_Domain => + pragma Assert (From_Aspect_Specification (N)); + -- The parser forbids this clause in source code, so it must have + -- come from an aspect specification. - -- Dispatching_Domain attribute definition clause not allowed - -- except from aspect specification. - - if From_Aspect_Specification (N) then - if not Is_Task_Type (U_Ent) then - Error_Msg_N - ("Dispatching_Domain can only be defined for task", Nam); - - elsif Duplicate_Clause then - null; + if not Is_Task_Type (U_Ent) then + Error_Msg_N + ("Dispatching_Domain can only be defined for task", Nam); - else - -- The expression must be analyzed in the special manner - -- described in "Handling of Default and Per-Object - -- Expressions" in sem.ads. + elsif Duplicate_Clause then + null; - -- The visibility to the components must be restored + else + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. - Push_Type (U_Ent); + -- The visibility to the components must be restored - Preanalyze_Spec_Expression - (Expr, RTE (RE_Dispatching_Domain)); + Push_Type (U_Ent); - Pop_Type (U_Ent); - end if; + Preanalyze_Spec_Expression + (Expr, RTE (RE_Dispatching_Domain)); - else - Error_Msg_N - ("attribute& cannot be set with definition clause", N); + Pop_Type (U_Ent); end if; ------------------ @@ -6557,43 +6630,37 @@ package body Sem_Ch13 is ------------------------ when Attribute_Interrupt_Priority => + pragma Assert (From_Aspect_Specification (N)); + -- The parser forbids this clause in source code, so it must have + -- come from an aspect specification. - -- Interrupt_Priority attribute definition clause not allowed - -- except from aspect specification. - - if From_Aspect_Specification (N) then - if not Is_Concurrent_Type (U_Ent) then - Error_Msg_N - ("Interrupt_Priority can only be defined for task and " - & "protected object", Nam); + if not Is_Concurrent_Type (U_Ent) then + Error_Msg_N + ("Interrupt_Priority can only be defined for task and " + & "protected object", Nam); - elsif Duplicate_Clause then - null; + elsif Duplicate_Clause then + null; - else - -- The expression must be analyzed in the special manner - -- described in "Handling of Default and Per-Object - -- Expressions" in sem.ads. + else + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. - -- The visibility to the components must be restored + -- The visibility to the components must be restored - Push_Type (U_Ent); + Push_Type (U_Ent); - Preanalyze_Spec_Expression - (Expr, RTE (RE_Interrupt_Priority)); + Preanalyze_Spec_Expression + (Expr, RTE (RE_Interrupt_Priority)); - Pop_Type (U_Ent); + Pop_Type (U_Ent); - -- Check the No_Task_At_Interrupt_Priority restriction + -- Check the No_Task_At_Interrupt_Priority restriction - if Is_Task_Type (U_Ent) then - Check_Restriction (No_Task_At_Interrupt_Priority, N); - end if; + if Is_Task_Type (U_Ent) then + Check_Restriction (No_Task_At_Interrupt_Priority, N); end if; - - else - Error_Msg_N - ("attribute& cannot be set with definition clause", N); end if; -------------- @@ -6992,6 +7059,121 @@ package body Sem_Ch13 is Pool : Entity_Id; T : Entity_Id; + procedure Associate_Storage_Pool + (Ent : Entity_Id; Pool : Entity_Id); + -- Associate Pool to Ent and perform legality checks on subpools + + ---------------------------- + -- Associate_Storage_Pool -- + ---------------------------- + + procedure Associate_Storage_Pool + (Ent : Entity_Id; Pool : Entity_Id) + is + function Object_From (Pool : Entity_Id) return Entity_Id; + -- Return the entity of which Pool is a part of + + ----------------- + -- Object_From -- + ----------------- + + function Object_From + (Pool : Entity_Id) return Entity_Id + is + N : Node_Id := Pool; + begin + if Present (Renamed_Object (Pool)) then + N := Renamed_Object (Pool); + end if; + + while Present (N) loop + case Nkind (N) is + when N_Defining_Identifier => + return N; + + when N_Identifier | N_Expanded_Name => + return Entity (N); + + when N_Indexed_Component | N_Selected_Component | + N_Explicit_Dereference + => + N := Prefix (N); + + when N_Type_Conversion => + N := Expression (N); + + when others => + -- ??? we probably should handle more cases but + -- this is good enough in practice for this check + -- on a corner case. + + return Empty; + end case; + end loop; + + return Empty; + end Object_From; + + Obj : Entity_Id; + + begin + Set_Associated_Storage_Pool (Ent, Pool); + + -- Check RM 13.11.4(22-23/3): a specification of a storage pool + -- is illegal if the storage pool supports subpools and: + -- (A) The access type is a general access type. + -- (B) The access type is statically deeper than the storage + -- pool object; + -- (C) The storage pool object is a part of a formal parameter; + -- (D) The storage pool object is a part of the dereference of + -- a non-library level general access type; + + if Ada_Version >= Ada_2012 + and then RTU_Loaded (System_Storage_Pools_Subpools) + and then + Is_Ancestor (RTE (RE_Root_Storage_Pool_With_Subpools), + Etype (Pool)) + then + -- check (A) + + if Ekind (Etype (Ent)) = E_General_Access_Type then + Error_Msg_N + ("subpool cannot be used on general access type", Ent); + end if; + + -- check (B) + + if Type_Access_Level (Ent) > Object_Access_Level (Pool) then + Error_Msg_N + ("subpool access type has deeper accessibility " + & "level than pool", Ent); + return; + end if; + + Obj := Object_From (Pool); + + -- check (C) + + if Present (Obj) and then Ekind (Obj) in Formal_Kind then + Error_Msg_N + ("subpool cannot be part of a parameter", Ent); + return; + end if; + + -- check (D) + + if Present (Obj) + and then Ekind (Etype (Obj)) = E_General_Access_Type + and then not Is_Library_Level_Entity (Etype (Obj)) + then + Error_Msg_N + ("subpool cannot be part of the dereference of a " & + "nested general access type", Ent); + return; + end if; + end if; + end Associate_Storage_Pool; + begin if Ekind (U_Ent) = E_Access_Subprogram_Type then Error_Msg_N @@ -6999,7 +7181,7 @@ package body Sem_Ch13 is Nam); return; - elsif not Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) + elsif Ekind (U_Ent) not in E_Access_Type | E_General_Access_Type then Error_Msg_N ("storage pool can only be given for access types", Nam); @@ -7115,7 +7297,7 @@ package body Sem_Ch13 is end if; Analyze (Rnode); - Set_Associated_Storage_Pool (U_Ent, Pool); + Associate_Storage_Pool (U_Ent, Pool); end; elsif Is_Entity_Name (Expr) then @@ -7137,14 +7319,14 @@ package body Sem_Ch13 is Pool := Entity (Expression (Renamed_Object (Pool))); end if; - Set_Associated_Storage_Pool (U_Ent, Pool); + Associate_Storage_Pool (U_Ent, Pool); elsif Nkind (Expr) = N_Type_Conversion and then Is_Entity_Name (Expression (Expr)) and then Nkind (Original_Node (Expr)) = N_Attribute_Reference then Pool := Entity (Expression (Expr)); - Set_Associated_Storage_Pool (U_Ent, Pool); + Associate_Storage_Pool (U_Ent, Pool); else Error_Msg_N ("incorrect reference to a Storage Pool", Expr); @@ -7402,10 +7584,10 @@ package body Sem_Ch13 is while Present (Decl) loop DeclO := Original_Node (Decl); if Comes_From_Source (DeclO) - and not Nkind_In (DeclO, N_Pragma, - N_Use_Package_Clause, - N_Use_Type_Clause, - N_Implicit_Label_Declaration) + and Nkind (DeclO) not in N_Pragma + | N_Use_Package_Clause + | N_Use_Type_Clause + | N_Implicit_Label_Declaration then Error_Msg_N ("this declaration not allowed in machine code subprogram", @@ -7434,9 +7616,8 @@ package body Sem_Ch13 is null; elsif Comes_From_Source (StmtO) - and then not Nkind_In (StmtO, N_Pragma, - N_Label, - N_Code_Statement) + and then Nkind (StmtO) not in + N_Pragma | N_Label | N_Code_Statement then Error_Msg_N ("this statement is not allowed in machine code subprogram", @@ -8931,6 +9112,25 @@ package body Sem_Ch13 is return RList'(1 => REnt'(SLo, SHi)); end if; + -- Others case + + elsif Nkind (N) = N_Others_Choice then + declare + Choices : constant List_Id := Others_Discrete_Choices (N); + Choice : Node_Id; + Range_List : RList (1 .. List_Length (Choices)); + + begin + Choice := First (Choices); + + for J in Range_List'Range loop + Range_List (J) := REnt'(Lo_Val (Choice), Hi_Val (Choice)); + Next (Choice); + end loop; + + return Range_List; + end; + -- Static expression case elsif Is_OK_Static_Expression (N) then @@ -8939,7 +9139,7 @@ package body Sem_Ch13 is -- Identifier (other than static expression) case - else pragma Assert (Nkind_In (N, N_Expanded_Name, N_Identifier)); + else pragma Assert (Nkind (N) in N_Expanded_Name | N_Identifier); -- Type case @@ -9798,11 +9998,10 @@ package body Sem_Ch13 is ------------------------------------- function Reset_Quantified_Variable_Scope - (N : Node_Id) return Traverse_Result - is + (N : Node_Id) return Traverse_Result is begin - if Nkind_In (N, N_Iterator_Specification, - N_Loop_Parameter_Specification) + if Nkind (N) in N_Iterator_Specification + | N_Loop_Parameter_Specification then Set_Scope (Defining_Identifier (N), Predicate_Function (Typ)); @@ -10338,6 +10537,8 @@ package body Sem_Ch13 is Preanalyze_Spec_Expression (End_Decl_Expr, T); Pop_Type (Ent); + elsif A_Id = Aspect_Predicate_Failure then + Preanalyze_Spec_Expression (End_Decl_Expr, Standard_String); else Preanalyze_Spec_Expression (End_Decl_Expr, T); end if; @@ -10778,12 +10979,12 @@ package body Sem_Ch13 is -- Otherwise look at the identifier and see if it is OK - if Ekind_In (Ent, E_Named_Integer, E_Named_Real) + if Ekind (Ent) in E_Named_Integer | E_Named_Real or else Is_Type (Ent) then return; - elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then + elsif Ekind (Ent) in E_Constant | E_In_Parameter then -- This is the case where we must have Ent defined before -- U_Ent. Clearly if they are in different units this @@ -10865,10 +11066,10 @@ package body Sem_Ch13 is Check_Expr_Constants (Prefix (Nod)); when N_Attribute_Reference => - if Nam_In (Attribute_Name (Nod), Name_Address, - Name_Access, - Name_Unchecked_Access, - Name_Unrestricted_Access) + if Attribute_Name (Nod) in Name_Address + | Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access then Check_At_Constant_Address (Prefix (Nod)); @@ -11087,7 +11288,7 @@ package body Sem_Ch13 is -- record, both at location zero. This seems a bit strange, but -- it seems to happen in some circumstances, perhaps on an error. - if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then + if Chars (C1_Ent) = Name_uTag then return; end if; @@ -11482,7 +11683,7 @@ package body Sem_Ch13 is Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); Pcomp := First_Entity (Tagged_Parent); while Present (Pcomp) loop - if Ekind_In (Pcomp, E_Discriminant, E_Component) then + if Ekind (Pcomp) in E_Discriminant | E_Component then if Component_Bit_Offset (Pcomp) /= No_Uint and then Known_Static_Esize (Pcomp) then @@ -11714,7 +11915,7 @@ package body Sem_Ch13 is -- This latter test is repeated recursively up the variant tree. Main_Component_Loop : while Present (C1_Ent) loop - if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then + if Ekind (C1_Ent) not in E_Component | E_Discriminant then goto Continue_Main_Component_Loop; end if; @@ -11745,8 +11946,8 @@ package body Sem_Ch13 is -- but be careful not to flag a non-girder discriminant -- and the girder discriminant it renames as overlapping. - if Nkind_In (Clist, N_Full_Type_Declaration, - N_Private_Type_Declaration) + if Nkind (Clist) in N_Full_Type_Declaration + | N_Private_Type_Declaration then if Has_Discriminants (Defining_Identifier (Clist)) then C2_Ent := @@ -12101,7 +12302,7 @@ package body Sem_Ch13 is -- The subprogram is inherited (implicitly declared), it does not -- override and does not cover a primitive of an interface. - if Ekind_In (Subp_Id, E_Function, E_Procedure) + if Ekind (Subp_Id) in E_Function | E_Procedure and then Present (Alias (Subp_Id)) and then No (Interface_Alias (Subp_Id)) and then No (Overridden_Operation (Subp_Id)) @@ -12591,6 +12792,234 @@ package body Sem_Ch13 is end if; end Get_Alignment_Value; + ----------------------------------- + -- Has_Compatible_Representation -- + ----------------------------------- + + function Has_Compatible_Representation + (Target_Type, Operand_Type : Entity_Id) return Boolean + is + T1 : constant Entity_Id := Underlying_Type (Target_Type); + T2 : constant Entity_Id := Underlying_Type (Operand_Type); + + begin + -- A quick check, if base types are the same, then we definitely have + -- the same representation, because the subtype specific representation + -- attributes (Size and Alignment) do not affect representation from + -- the point of view of this test. + + if Base_Type (T1) = Base_Type (T2) then + return True; + + elsif Is_Private_Type (Base_Type (T2)) + and then Base_Type (T1) = Full_View (Base_Type (T2)) + then + return True; + + -- If T2 is a generic actual it is declared as a subtype, so + -- check against its base type. + + elsif Is_Generic_Actual_Type (T1) + and then Has_Compatible_Representation (Base_Type (T1), T2) + then + return True; + end if; + + -- Tagged types always have the same representation, because it is not + -- possible to specify different representations for common fields. + + if Is_Tagged_Type (T1) then + return True; + end if; + + -- Representations are definitely different if conventions differ + + if Convention (T1) /= Convention (T2) then + return False; + end if; + + -- Representations are different if component alignments or scalar + -- storage orders differ. + + if (Is_Record_Type (T1) or else Is_Array_Type (T1)) + and then + (Is_Record_Type (T2) or else Is_Array_Type (T2)) + and then + (Component_Alignment (T1) /= Component_Alignment (T2) + or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) + then + return False; + end if; + + -- For arrays, the only real issue is component size. If we know the + -- component size for both arrays, and it is the same, then that's + -- good enough to know we don't have a change of representation. + + if Is_Array_Type (T1) then + + -- In a view conversion, if the target type is an array type having + -- aliased components and the operand type is an array type having + -- unaliased components, then a new object is created (4.6(58.3/4)). + + if Has_Aliased_Components (T1) + and then not Has_Aliased_Components (T2) + then + return False; + end if; + + if Known_Component_Size (T1) + and then Known_Component_Size (T2) + and then Component_Size (T1) = Component_Size (T2) + then + return True; + end if; + end if; + + -- For records, representations are different if reorderings differ + + if Is_Record_Type (T1) + and then Is_Record_Type (T2) + and then No_Reordering (T1) /= No_Reordering (T2) + then + return False; + end if; + + -- Types definitely have same representation if neither has non-standard + -- representation since default representations are always consistent. + -- If only one has non-standard representation, and the other does not, + -- then we consider that they do not have the same representation. They + -- might, but there is no way of telling early enough. + + if Has_Non_Standard_Rep (T1) then + if not Has_Non_Standard_Rep (T2) then + return False; + end if; + else + return not Has_Non_Standard_Rep (T2); + end if; + + -- Here the two types both have non-standard representation, and we need + -- to determine if they have the same non-standard representation. + + -- For arrays, we simply need to test if the component sizes are the + -- same. Pragma Pack is reflected in modified component sizes, so this + -- check also deals with pragma Pack. + + if Is_Array_Type (T1) then + return Component_Size (T1) = Component_Size (T2); + + -- Case of record types + + elsif Is_Record_Type (T1) then + + -- Packed status must conform + + if Is_Packed (T1) /= Is_Packed (T2) then + return False; + + -- Otherwise we must check components. Typ2 maybe a constrained + -- subtype with fewer components, so we compare the components + -- of the base types. + + else + Record_Case : declare + CD1, CD2 : Entity_Id; + + function Same_Rep return Boolean; + -- CD1 and CD2 are either components or discriminants. This + -- function tests whether they have the same representation. + + -------------- + -- Same_Rep -- + -------------- + + function Same_Rep return Boolean is + begin + if No (Component_Clause (CD1)) then + return No (Component_Clause (CD2)); + else + -- Note: at this point, component clauses have been + -- normalized to the default bit order, so that the + -- comparison of Component_Bit_Offsets is meaningful. + + return + Present (Component_Clause (CD2)) + and then + Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) + and then + Esize (CD1) = Esize (CD2); + end if; + end Same_Rep; + + -- Start of processing for Record_Case + + begin + if Has_Discriminants (T1) then + + -- The number of discriminants may be different if the + -- derived type has fewer (constrained by values). The + -- invisible discriminants retain the representation of + -- the original, so the discrepancy does not per se + -- indicate a different representation. + + CD1 := First_Discriminant (T1); + CD2 := First_Discriminant (T2); + while Present (CD1) and then Present (CD2) loop + if not Same_Rep then + return False; + else + Next_Discriminant (CD1); + Next_Discriminant (CD2); + end if; + end loop; + end if; + + CD1 := First_Component (Underlying_Type (Base_Type (T1))); + CD2 := First_Component (Underlying_Type (Base_Type (T2))); + while Present (CD1) loop + if not Same_Rep then + return False; + else + Next_Component (CD1); + Next_Component (CD2); + end if; + end loop; + + return True; + end Record_Case; + end if; + + -- For enumeration types, we must check each literal to see if the + -- representation is the same. Note that we do not permit enumeration + -- representation clauses for Character and Wide_Character, so these + -- cases were already dealt with. + + elsif Is_Enumeration_Type (T1) then + Enumeration_Case : declare + L1, L2 : Entity_Id; + + begin + L1 := First_Literal (T1); + L2 := First_Literal (T2); + while Present (L1) loop + if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then + return False; + else + Next_Literal (L1); + Next_Literal (L2); + end if; + end loop; + + return True; + end Enumeration_Case; + + -- Any other types have the same representation for these purposes + + else + return True; + end if; + end Has_Compatible_Representation; + ------------------------------------- -- Inherit_Aspects_At_Freeze_Point -- ------------------------------------- @@ -12629,9 +13058,8 @@ package body Sem_Ch13 is return Entity (Rep_Item); else - pragma Assert (Nkind_In (Rep_Item, - N_Attribute_Definition_Clause, - N_Pragma)); + pragma Assert + (Nkind (Rep_Item) in N_Attribute_Definition_Clause | N_Pragma); return Entity (Name (Rep_Item)); end if; end Rep_Item_Entity; @@ -13055,7 +13483,7 @@ package body Sem_Ch13 is -- 20. A call to a predefined boolean logical operator, where each -- operand is predicate-static. - elsif (Nkind_In (Expr, N_Op_And, N_Op_Or, N_Op_Xor) + elsif (Nkind (Expr) in N_Op_And | N_Op_Or | N_Op_Xor and then Is_Predicate_Static (Left_Opnd (Expr), Nam) and then Is_Predicate_Static (Right_Opnd (Expr), Nam)) or else @@ -13919,7 +14347,7 @@ package body Sem_Ch13 is -- A self-referential aspect is illegal if it forces freezing the -- entity before the corresponding pragma has been analyzed. - if Nkind_In (N, N_Attribute_Definition_Clause, N_Pragma) + if Nkind (N) in N_Attribute_Definition_Clause | N_Pragma and then From_Aspect_Specification (N) then Error_Msg_NE @@ -14045,8 +14473,8 @@ package body Sem_Ch13 is declare Pname : constant Name_Id := Pragma_Name (N); begin - if Nam_In (Pname, Name_Convention, Name_Import, Name_Export, - Name_External, Name_Interface) + if Pname in Name_Convention | Name_Import | Name_Export + | Name_External | Name_Interface then return False; end if; @@ -14456,221 +14884,6 @@ package body Sem_Ch13 is end loop; end Resolve_Aspect_Expressions; - ------------------------- - -- Same_Representation -- - ------------------------- - - function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is - T1 : constant Entity_Id := Underlying_Type (Typ1); - T2 : constant Entity_Id := Underlying_Type (Typ2); - - begin - -- A quick check, if base types are the same, then we definitely have - -- the same representation, because the subtype specific representation - -- attributes (Size and Alignment) do not affect representation from - -- the point of view of this test. - - if Base_Type (T1) = Base_Type (T2) then - return True; - - elsif Is_Private_Type (Base_Type (T2)) - and then Base_Type (T1) = Full_View (Base_Type (T2)) - then - return True; - - -- If T2 is a generic actual it is declared as a subtype, so - -- check against its base type. - - elsif Is_Generic_Actual_Type (T1) - and then Same_Representation (Base_Type (T1), T2) - then - return True; - end if; - - -- Tagged types always have the same representation, because it is not - -- possible to specify different representations for common fields. - - if Is_Tagged_Type (T1) then - return True; - end if; - - -- Representations are definitely different if conventions differ - - if Convention (T1) /= Convention (T2) then - return False; - end if; - - -- Representations are different if component alignments or scalar - -- storage orders differ. - - if (Is_Record_Type (T1) or else Is_Array_Type (T1)) - and then - (Is_Record_Type (T2) or else Is_Array_Type (T2)) - and then - (Component_Alignment (T1) /= Component_Alignment (T2) - or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) - then - return False; - end if; - - -- For arrays, the only real issue is component size. If we know the - -- component size for both arrays, and it is the same, then that's - -- good enough to know we don't have a change of representation. - - if Is_Array_Type (T1) then - if Known_Component_Size (T1) - and then Known_Component_Size (T2) - and then Component_Size (T1) = Component_Size (T2) - then - return True; - end if; - end if; - - -- For records, representations are different if reorderings differ - - if Is_Record_Type (T1) - and then Is_Record_Type (T2) - and then No_Reordering (T1) /= No_Reordering (T2) - then - return False; - end if; - - -- Types definitely have same representation if neither has non-standard - -- representation since default representations are always consistent. - -- If only one has non-standard representation, and the other does not, - -- then we consider that they do not have the same representation. They - -- might, but there is no way of telling early enough. - - if Has_Non_Standard_Rep (T1) then - if not Has_Non_Standard_Rep (T2) then - return False; - end if; - else - return not Has_Non_Standard_Rep (T2); - end if; - - -- Here the two types both have non-standard representation, and we need - -- to determine if they have the same non-standard representation. - - -- For arrays, we simply need to test if the component sizes are the - -- same. Pragma Pack is reflected in modified component sizes, so this - -- check also deals with pragma Pack. - - if Is_Array_Type (T1) then - return Component_Size (T1) = Component_Size (T2); - - -- Case of record types - - elsif Is_Record_Type (T1) then - - -- Packed status must conform - - if Is_Packed (T1) /= Is_Packed (T2) then - return False; - - -- Otherwise we must check components. Typ2 maybe a constrained - -- subtype with fewer components, so we compare the components - -- of the base types. - - else - Record_Case : declare - CD1, CD2 : Entity_Id; - - function Same_Rep return Boolean; - -- CD1 and CD2 are either components or discriminants. This - -- function tests whether they have the same representation. - - -------------- - -- Same_Rep -- - -------------- - - function Same_Rep return Boolean is - begin - if No (Component_Clause (CD1)) then - return No (Component_Clause (CD2)); - else - -- Note: at this point, component clauses have been - -- normalized to the default bit order, so that the - -- comparison of Component_Bit_Offsets is meaningful. - - return - Present (Component_Clause (CD2)) - and then - Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) - and then - Esize (CD1) = Esize (CD2); - end if; - end Same_Rep; - - -- Start of processing for Record_Case - - begin - if Has_Discriminants (T1) then - - -- The number of discriminants may be different if the - -- derived type has fewer (constrained by values). The - -- invisible discriminants retain the representation of - -- the original, so the discrepancy does not per se - -- indicate a different representation. - - CD1 := First_Discriminant (T1); - CD2 := First_Discriminant (T2); - while Present (CD1) and then Present (CD2) loop - if not Same_Rep then - return False; - else - Next_Discriminant (CD1); - Next_Discriminant (CD2); - end if; - end loop; - end if; - - CD1 := First_Component (Underlying_Type (Base_Type (T1))); - CD2 := First_Component (Underlying_Type (Base_Type (T2))); - while Present (CD1) loop - if not Same_Rep then - return False; - else - Next_Component (CD1); - Next_Component (CD2); - end if; - end loop; - - return True; - end Record_Case; - end if; - - -- For enumeration types, we must check each literal to see if the - -- representation is the same. Note that we do not permit enumeration - -- representation clauses for Character and Wide_Character, so these - -- cases were already dealt with. - - elsif Is_Enumeration_Type (T1) then - Enumeration_Case : declare - L1, L2 : Entity_Id; - - begin - L1 := First_Literal (T1); - L2 := First_Literal (T2); - while Present (L1) loop - if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then - return False; - else - Next_Literal (L1); - Next_Literal (L2); - end if; - end loop; - - return True; - end Enumeration_Case; - - -- Any other types have the same representation for these purposes - - else - return True; - end if; - end Same_Representation; - ---------------------------- -- Parse_Aspect_Aggregate -- ---------------------------- @@ -15814,10 +16027,12 @@ package body Sem_Ch13 is Match_Found : Boolean := False; Is_Match : Boolean; Match : Interp; + begin if not Is_Type (Typ) then Error_Msg_N ("aspect can only be specified for a type", ASN); return; + elsif not Is_First_Subtype (Typ) then Error_Msg_N ("aspect cannot be specified for a subtype", ASN); return; @@ -15828,12 +16043,15 @@ package body Sem_Ch13 is Error_Msg_N ("aspect cannot be specified for a string type", ASN); return; end if; + Param_Type := Standard_Wide_Wide_String; + else if Is_Numeric_Type (Typ) then Error_Msg_N ("aspect cannot be specified for a numeric type", ASN); return; end if; + Param_Type := Standard_String; end if; @@ -15857,17 +16075,21 @@ package body Sem_Ch13 is and then Base_Type (Etype (It.Nam)) = Typ then declare - Params : constant List_Id := + Params : constant List_Id := Parameter_Specifications (Parent (It.Nam)); Param_Spec : Node_Id; Param_Id : Entity_Id; + begin if List_Length (Params) = 1 then Param_Spec := First (Params); + if not More_Ids (Param_Spec) then Param_Id := Defining_Identifier (Param_Spec); + if Base_Type (Etype (Param_Id)) = Param_Type - and then Ekind (Param_Id) = E_In_Parameter + and then Ekind (Param_Id) = E_In_Parameter + and then not Is_Aliased (Param_Id) then Is_Match := True; end if; @@ -15881,6 +16103,7 @@ package body Sem_Ch13 is Error_Msg_N ("aspect specification is ambiguous", ASN); return; end if; + Match_Found := True; Match := It; end if; diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 43aea2a..3d24c04 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -128,6 +128,14 @@ package Sem_Ch13 is -- If the size is too small, and an error message is given, then both -- Esize and RM_Size are reset to the allowed minimum value in T. + function Has_Compatible_Representation + (Target_Type, Operand_Type : Entity_Id) return Boolean; + -- Given two types, where the two types are related by possible derivation, + -- determines if the two types have compatible representation, or different + -- representations, requiring the special processing for representation + -- change. A False result is possible only for array, enumeration or + -- record types. + procedure Parse_Aspect_Aggregate (N : Node_Id; Empty_Subp : in out Node_Id; @@ -196,13 +204,6 @@ package Sem_Ch13 is -- because such clauses are linked on to the Rep_Item chain in procedure -- Sem_Ch13.Analyze_Aspect_Specifications. See that procedure for details. - function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean; - -- Given two types, where the two types are related by possible derivation, - -- determines if the two types have the same representation, or different - -- representations, requiring the special processing for representation - -- change. A False result is possible only for array, enumeration or - -- record types. - procedure Validate_Unchecked_Conversion (N : Node_Id; Act_Unit : Entity_Id); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a184a87..a5690d6 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -579,6 +579,12 @@ package body Sem_Ch3 is -- Extensions_Visible with value False and has at least one controlling -- parameter of mode OUT. + function Is_Private_Primitive (Prim : Entity_Id) return Boolean; + -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. + -- When applied to a primitive subprogram Prim, returns True if Prim is + -- declared as a private operation within a package or generic package, + -- and returns False otherwise. + function Is_Valid_Constraint_Kind (T_Kind : Type_Kind; Constraint_Kind : Node_Kind) return Boolean; @@ -745,8 +751,8 @@ package body Sem_Ch3 is -- function, scope is the current one, because it is the one of the -- current type declaration, except for the pathological case below. - if Nkind_In (Related_Nod, N_Object_Declaration, - N_Access_Function_Definition) + if Nkind (Related_Nod) in + N_Object_Declaration | N_Access_Function_Definition then Anon_Scope := Current_Scope; @@ -759,8 +765,8 @@ package body Sem_Ch3 is begin Par := Related_Nod; - while Nkind_In (Par, N_Access_Function_Definition, - N_Access_Definition) + while Nkind (Par) in + N_Access_Function_Definition | N_Access_Definition loop Par := Parent (Par); end loop; @@ -1072,20 +1078,18 @@ package body Sem_Ch3 is -- (Z : access T))) D_Ityp := Associated_Node_For_Itype (Desig_Type); - while not (Nkind_In (D_Ityp, N_Full_Type_Declaration, - N_Private_Type_Declaration, - N_Private_Extension_Declaration, - N_Procedure_Specification, - N_Function_Specification, - N_Entry_Body) - - or else - Nkind_In (D_Ityp, N_Object_Declaration, - N_Object_Renaming_Declaration, - N_Formal_Object_Declaration, - N_Formal_Type_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration)) + while Nkind (D_Ityp) not in N_Full_Type_Declaration + | N_Private_Type_Declaration + | N_Private_Extension_Declaration + | N_Procedure_Specification + | N_Function_Specification + | N_Entry_Body + | N_Object_Declaration + | N_Object_Renaming_Declaration + | N_Formal_Object_Declaration + | N_Formal_Type_Declaration + | N_Task_Type_Declaration + | N_Protected_Type_Declaration loop D_Ityp := Parent (D_Ityp); pragma Assert (D_Ityp /= Empty); @@ -1093,15 +1097,14 @@ package body Sem_Ch3 is Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); - if Nkind_In (D_Ityp, N_Procedure_Specification, - N_Function_Specification) + if Nkind (D_Ityp) in N_Procedure_Specification | N_Function_Specification then Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); - elsif Nkind_In (D_Ityp, N_Full_Type_Declaration, - N_Object_Declaration, - N_Object_Renaming_Declaration, - N_Formal_Type_Declaration) + elsif Nkind (D_Ityp) in N_Full_Type_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration + | N_Formal_Type_Declaration then Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); end if; @@ -2343,9 +2346,9 @@ package body Sem_Ch3 is -- because they have already been resolved. elsif Decls = Visible_Declarations (Context) - and then Ekind_In (Typ, E_Limited_Private_Type, - E_Private_Type, - E_Record_Type_With_Private) + and then Ekind (Typ) in E_Limited_Private_Type + | E_Private_Type + | E_Record_Type_With_Private and then Has_Own_Invariants (Typ) then Build_Invariant_Procedure_Body @@ -2490,9 +2493,9 @@ package body Sem_Ch3 is -- controlled primitives. if Nkind (Body_Spec) /= N_Procedure_Specification - or else not Nam_In (Chars (Body_Id), Name_Adjust, - Name_Finalize, - Name_Initialize) + or else Chars (Body_Id) not in Name_Adjust + | Name_Finalize + | Name_Initialize then return; @@ -2527,7 +2530,7 @@ package body Sem_Ch3 is Spec_Id := Current_Entity (Body_Id); while Present (Spec_Id) loop - if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) + if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure and then Scope (Spec_Id) = Current_Scope and then Present (First_Formal (Spec_Id)) and then No (Next_Formal (First_Formal (Spec_Id))) @@ -2666,8 +2669,8 @@ package body Sem_Ch3 is if Nkind (Parent (L)) = N_Component_List then null; - elsif Nkind_In (Parent (L), N_Protected_Definition, - N_Task_Definition) + elsif Nkind (Parent (L)) in + N_Protected_Definition | N_Task_Definition then Check_Entry_Contracts; @@ -3607,7 +3610,7 @@ package body Sem_Ch3 is return; end if; - if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then + if Nkind (E) in N_Integer_Literal | N_Real_Literal then Set_Etype (E, Etype (Id)); end if; @@ -3668,7 +3671,7 @@ package body Sem_Ch3 is -- has aspects that require delayed analysis, the resolution of the -- aggregate must be deferred to the freeze point of the object. This -- special processing was created for address clauses, but it must - -- also apply to Alignment. This must be done before the aspect + -- also apply to address aspects. This must be done before the aspect -- specifications are analyzed because we must handle the aggregate -- before the analysis of the object declaration is complete. @@ -3891,10 +3894,12 @@ package body Sem_Ch3 is begin if Present (Aspect_Specifications (N)) then - A := First (Aspect_Specifications (N)); - A_Id := Get_Aspect_Id (Chars (Identifier (A))); + A := First (Aspect_Specifications (N)); + while Present (A) loop - if A_Id = Aspect_Alignment or else A_Id = Aspect_Address then + A_Id := Get_Aspect_Id (Chars (Identifier (A))); + + if A_Id = Aspect_Address then -- Set flag on object entity, for later processing at -- the freeze point. @@ -4047,7 +4052,7 @@ package body Sem_Ch3 is then null; - else + elsif Comes_From_Source (Id) then declare Save_Typ : constant Entity_Id := Etype (Id); begin @@ -5078,7 +5083,7 @@ package body Sem_Ch3 is ("parent of type extension must be a tagged type ", Indic); goto Leave; - elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then + elsif Ekind (Parent_Type) in E_Void | E_Incomplete_Type then Error_Msg_N ("premature derivation of incomplete type", Indic); goto Leave; @@ -5713,11 +5718,13 @@ package body Sem_Ch3 is -- If the base type is a scalar type, or else if there is no -- constraint, the atomic flag is inherited by the subtype. + -- Ditto for the Independent aspect. if Is_Scalar_Type (Id) or else Is_Entity_Name (Subtype_Indication (N)) then Set_Is_Atomic (Id, Is_Atomic (T)); + Set_Is_Independent (Id, Is_Independent (T)); end if; -- Remaining processing depends on characteristics of base type @@ -6428,7 +6435,7 @@ package body Sem_Ch3 is Mark_Rewrite_Insertion (Comp); - if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) + if Nkind (N) in N_Object_Declaration | N_Access_Function_Definition or else (Nkind (Parent (N)) = N_Full_Type_Declaration and then not Is_Type (Current_Scope)) then @@ -6504,10 +6511,10 @@ package body Sem_Ch3 is end Replace_Type_Name; begin - if Ekind_In (Id, E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Subprogram_Type) + if Ekind (Id) in E_Access_Subprogram_Type + | E_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Subprogram_Type then null; @@ -10470,9 +10477,9 @@ package body Sem_Ch3 is -- build-in-place library function, child unit or not. if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod)) - or else (Nkind_In (Nod, N_Defining_Program_Unit_Name, - N_Subprogram_Declaration) - and then Is_Compilation_Unit (Defining_Entity (Nod))) + or else (Nkind (Nod) in + N_Defining_Program_Unit_Name | N_Subprogram_Declaration + and then Is_Compilation_Unit (Defining_Entity (Nod))) then Add_Global_Declaration (IR); else @@ -10502,7 +10509,7 @@ package body Sem_Ch3 is Analyze_And_Resolve (Bound, Base_Type (Par_T)); - if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then + if Nkind (Bound) in N_Integer_Literal | N_Real_Literal then New_Bound := New_Copy (Bound); Set_Etype (New_Bound, Der_T); Set_Analyzed (New_Bound); @@ -10752,6 +10759,26 @@ package body Sem_Ch3 is elsif Present (Interface_Alias (Subp)) then null; + -- AI12-0042: Test for rule in 7.3.2(6.1/4), that requires overriding + -- of a visible private primitive inherited from an ancestor with + -- the aspect Type_Invariant'Class, unless the inherited primitive + -- is abstract. + + elsif not Is_Abstract_Subprogram (Subp) + and then not Comes_From_Source (Subp) -- An inherited subprogram + and then Requires_Overriding (Subp) + and then Present (Alias_Subp) + and then Has_Invariants (Etype (T)) + and then Present (Get_Pragma (Etype (T), Pragma_Invariant)) + and then Class_Present (Get_Pragma (Etype (T), Pragma_Invariant)) + and then Is_Private_Primitive (Alias_Subp) + then + Error_Msg_NE + ("inherited private primitive & must be overridden", T, Subp); + Error_Msg_N + ("\because ancestor type has 'Type_'Invariant''Class " & + "(RM 7.3.2(6.1))", T); + elsif (Is_Abstract_Subprogram (Subp) or else Requires_Overriding (Subp) or else @@ -11513,7 +11540,7 @@ package body Sem_Ch3 is begin if not Comes_From_Source (E) then - if Ekind_In (E, E_Task_Type, E_Protected_Type) then + if Ekind (E) in E_Task_Type | E_Protected_Type then -- It may be an anonymous protected type created for a -- single variable. Post error on variable, if present. @@ -11643,10 +11670,10 @@ package body Sem_Ch3 is -- this kind is reserved for predefined operators, that are -- intrinsic and do not need completion. - elsif Ekind_In (E, E_Function, - E_Procedure, - E_Generic_Function, - E_Generic_Procedure) + elsif Ekind (E) in E_Function + | E_Procedure + | E_Generic_Function + | E_Generic_Procedure then if Has_Completion (E) then null; @@ -11705,7 +11732,7 @@ package body Sem_Ch3 is Post_Error; end if; - elsif Ekind_In (E, E_Task_Type, E_Protected_Type) then + elsif Ekind (E) in E_Task_Type | E_Protected_Type then if not Has_Completion (E) then Post_Error; end if; @@ -14587,7 +14614,7 @@ package body Sem_Ch3 is if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then Old_C := First_Component (Typ); while Present (Old_C) loop - if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then + if Chars (Old_C) in Name_uTag | Name_uParent then Append_Elmt (Old_C, Comp_List); end if; @@ -15432,9 +15459,9 @@ package body Sem_Ch3 is or else Is_Private_Overriding or else Is_Internal_Name (Chars (Parent_Subp)) or else (Is_Controlled (Parent_Type) - and then Nam_In (Chars (Parent_Subp), Name_Adjust, - Name_Finalize, - Name_Initialize)) + and then Chars (Parent_Subp) in Name_Adjust + | Name_Finalize + | Name_Initialize) then Set_Derived_Name; @@ -15633,9 +15660,9 @@ package body Sem_Ch3 is -- set on both views of the type. if Is_Controlled (Parent_Type) - and then Nam_In (Chars (Parent_Subp), Name_Initialize, - Name_Adjust, - Name_Finalize) + and then Chars (Parent_Subp) in Name_Initialize + | Name_Adjust + | Name_Finalize and then Is_Hidden (Parent_Subp) and then not Is_Visibly_Controlled (Parent_Type) then @@ -15674,6 +15701,9 @@ package body Sem_Ch3 is -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). + -- Ada 202x (AI12-0042): Similarly, set those properties for + -- implementing the rule of RM 7.3.2(6.1/4). + -- A subprogram subject to pragma Extensions_Visible with value False -- requires overriding if the subprogram has at least one controlling -- OUT parameter (SPARK RM 6.1.7(6)). @@ -15690,7 +15720,26 @@ package body Sem_Ch3 is Derived_Type and then not Is_Null_Extension (Derived_Type)) or else (Comes_From_Source (Alias (New_Subp)) - and then Is_EVF_Procedure (Alias (New_Subp)))) + and then Is_EVF_Procedure (Alias (New_Subp))) + + -- AI12-0042: Set Requires_Overriding when a type extension + -- inherits a private operation that is visible at the + -- point of extension (Has_Private_Ancestor is False) from + -- an ancestor that has Type_Invariant'Class, and when the + -- type extension is in a visible part (the latter as + -- clarified by AI12-0382). + + or else + (not Has_Private_Ancestor (Derived_Type) + and then Has_Invariants (Parent_Type) + and then + Present (Get_Pragma (Parent_Type, Pragma_Invariant)) + and then + Class_Present + (Get_Pragma (Parent_Type, Pragma_Invariant)) + and then Is_Private_Primitive (Parent_Subp) + and then In_Visible_Part (Scope (Derived_Type)))) + and then No (Actual_Subp) then if not Is_Tagged_Type (Derived_Type) @@ -16832,7 +16881,7 @@ package body Sem_Ch3 is -- Check for early use of incomplete or private type - if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then + if Ekind (Parent_Type) in E_Void | E_Incomplete_Type then Error_Msg_N ("premature derivation of incomplete type", Indic); return; @@ -17369,14 +17418,14 @@ package body Sem_Ch3 is -- Check invalid completion of private or incomplete type - elsif not Nkind_In (N, N_Full_Type_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration) + elsif Nkind (N) not in N_Full_Type_Declaration + | N_Task_Type_Declaration + | N_Protected_Type_Declaration and then (Ada_Version < Ada_2012 or else not Is_Incomplete_Type (Prev) - or else not Nkind_In (N, N_Private_Type_Declaration, - N_Private_Extension_Declaration)) + or else Nkind (N) not in N_Private_Type_Declaration + | N_Private_Extension_Declaration) then -- Completion must be a full type declarations (RM 7.3(4)) @@ -17453,9 +17502,8 @@ package body Sem_Ch3 is end if; if Nkind (N) = N_Full_Type_Declaration - and then Nkind_In - (Type_Definition (N), N_Record_Definition, - N_Derived_Type_Definition) + and then Nkind (Type_Definition (N)) in + N_Record_Definition | N_Derived_Type_Definition and then Interface_Present (Type_Definition (N)) then Error_Msg_N @@ -17472,15 +17520,15 @@ package body Sem_Ch3 is New_Id := Id; elsif Ekind (Prev) = E_Private_Type - and then Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) + and then Nkind (N) in N_Task_Type_Declaration + | N_Protected_Type_Declaration then Error_Msg_N ("completion of nonlimited type cannot be limited", N); elsif Ekind (Prev) = E_Record_Type_With_Private - and then Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) + and then Nkind (N) in N_Task_Type_Declaration + | N_Protected_Type_Declaration then if not Is_Limited_Record (Prev) then Error_Msg_N @@ -17497,8 +17545,8 @@ package body Sem_Ch3 is -- type or a protected type. This case arises when covering -- interface types. - elsif Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) + elsif Nkind (N) in N_Task_Type_Declaration + | N_Protected_Type_Declaration then null; @@ -17595,8 +17643,8 @@ package body Sem_Ch3 is if Ada_Version >= Ada_2012 and then Is_Incomplete_Type (Prev) - and then Nkind_In (N, N_Private_Type_Declaration, - N_Private_Extension_Declaration) + and then Nkind (N) in N_Private_Type_Declaration + | N_Private_Extension_Declaration then -- No need to check private extensions since they are tagged @@ -17610,8 +17658,8 @@ package body Sem_Ch3 is -- a synchronized type that implements interfaces) or a -- type extension, otherwise this is an error. - elsif Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) + elsif Nkind (N) in N_Task_Type_Declaration + | N_Protected_Type_Declaration then if No (Interface_List (N)) and then not Error_Posted (N) then Tag_Mismatch; @@ -17679,8 +17727,8 @@ package body Sem_Ch3 is -- Case of an anonymous array subtype - if Nkind_In (Def_Kind, N_Constrained_Array_Definition, - N_Unconstrained_Array_Definition) + if Def_Kind in + N_Constrained_Array_Definition | N_Unconstrained_Array_Definition then T := Empty; Array_Type_Declaration (T, Obj_Def); @@ -18619,8 +18667,7 @@ package body Sem_Ch3 is then null; - elsif Ekind_In (Derived_Base, E_Private_Type, - E_Limited_Private_Type) + elsif Ekind (Derived_Base) in E_Private_Type | E_Limited_Private_Type then null; @@ -18725,6 +18772,29 @@ package body Sem_Ch3 is end if; end Is_Null_Extension; + -------------------------- + -- Is_Private_Primitive -- + -------------------------- + + function Is_Private_Primitive (Prim : Entity_Id) return Boolean is + Prim_Scope : constant Entity_Id := Scope (Prim); + Priv_Entity : Entity_Id; + begin + if Is_Package_Or_Generic_Package (Prim_Scope) then + Priv_Entity := First_Private_Entity (Prim_Scope); + + while Present (Priv_Entity) loop + if Priv_Entity = Prim then + return True; + end if; + + Next_Entity (Priv_Entity); + end loop; + end if; + + return False; + end Is_Private_Primitive; + ------------------------------ -- Is_Valid_Constraint_Kind -- ------------------------------ @@ -18741,16 +18811,13 @@ package body Sem_Ch3 is return Constraint_Kind = N_Range_Constraint; when Decimal_Fixed_Point_Kind => - return Nkind_In (Constraint_Kind, N_Digits_Constraint, - N_Range_Constraint); + return Constraint_Kind in N_Digits_Constraint | N_Range_Constraint; when Ordinary_Fixed_Point_Kind => - return Nkind_In (Constraint_Kind, N_Delta_Constraint, - N_Range_Constraint); + return Constraint_Kind in N_Delta_Constraint | N_Range_Constraint; when Float_Kind => - return Nkind_In (Constraint_Kind, N_Digits_Constraint, - N_Range_Constraint); + return Constraint_Kind in N_Digits_Constraint | N_Range_Constraint; when Access_Kind | Array_Kind @@ -18810,7 +18877,7 @@ package body Sem_Ch3 is -- Start of processing for Is_Visible_Component begin - if Ekind_In (C, E_Component, E_Discriminant) then + if Ekind (C) in E_Component | E_Discriminant then Original_Comp := Original_Record_Component (C); end if; @@ -20636,9 +20703,9 @@ package body Sem_Ch3 is Priv := Node (Priv_Elmt); Priv_Scop := Scope (Priv); - if Ekind_In (Priv, E_Private_Subtype, - E_Limited_Private_Subtype, - E_Record_Subtype_With_Private) + if Ekind (Priv) in E_Private_Subtype + | E_Limited_Private_Subtype + | E_Record_Subtype_With_Private then Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); Set_Is_Itype (Full); @@ -20809,7 +20876,7 @@ package body Sem_Ch3 is Prim := Next_Entity (Full_T); while Present (Prim) and then Prim /= Priv_T loop - if Ekind_In (Prim, E_Procedure, E_Function) then + if Ekind (Prim) in E_Procedure | E_Function then Disp_Typ := Find_Dispatching_Type (Prim); if Disp_Typ = Full_T @@ -21263,17 +21330,16 @@ package body Sem_Ch3 is exit when Nkind (Insert_Node) in N_Declaration and then - not Nkind_In - (Insert_Node, N_Component_Declaration, - N_Loop_Parameter_Specification, - N_Function_Specification, - N_Procedure_Specification); - - exit when Nkind (Insert_Node) in N_Later_Decl_Item - or else Nkind (Insert_Node) in - N_Statement_Other_Than_Procedure_Call - or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, - N_Pragma); + Nkind (Insert_Node) not in N_Component_Declaration + | N_Loop_Parameter_Specification + | N_Function_Specification + | N_Procedure_Specification; + + exit when Nkind (Insert_Node) in + N_Later_Decl_Item | + N_Statement_Other_Than_Procedure_Call | + N_Procedure_Call_Statement | + N_Pragma; Insert_Node := Parent (Insert_Node); end loop; @@ -21487,20 +21553,19 @@ package body Sem_Ch3 is -- The following is ugly, can't we have a range or even a flag??? May_Have_Null_Exclusion := - Nkind_In (P, N_Access_Definition, - N_Access_Function_Definition, - N_Access_Procedure_Definition, - N_Access_To_Object_Definition, - N_Allocator, - N_Component_Definition) - or else - Nkind_In (P, N_Derived_Type_Definition, - N_Discriminant_Specification, - N_Formal_Object_Declaration, - N_Object_Declaration, - N_Object_Renaming_Declaration, - N_Parameter_Specification, - N_Subtype_Declaration); + Nkind (P) in N_Access_Definition + | N_Access_Function_Definition + | N_Access_Procedure_Definition + | N_Access_To_Object_Definition + | N_Allocator + | N_Component_Definition + | N_Derived_Type_Definition + | N_Discriminant_Specification + | N_Formal_Object_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration + | N_Parameter_Specification + | N_Subtype_Declaration; -- Create an Itype that is a duplicate of Entity (S) but with the -- null-exclusion attribute. diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 02fe39b..bb29904 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -241,7 +241,7 @@ package Sem_Ch3 is -- Default and per object expressions do not freeze their components, and -- must be analyzed and resolved accordingly. The analysis is done by -- calling the Preanalyze_And_Resolve routine and setting the global - -- In_Default_Expression flag. See the documentation section entitled + -- In_Spec_Expression flag. See the documentation section entitled -- "Handling of Default and Per-Object Expressions" in sem.ads for full -- details. N is the expression to be analyzed, T is the expected type. -- This mechanism is also used for aspect specifications that have an diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 517f5fc..c92fb06 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -380,7 +380,7 @@ package body Sem_Ch4 is if Nkind (N) in N_Membership_Test then Error_Msg_N ("ambiguous operands for membership", N); - elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then + elsif Nkind (N) in N_Op_Eq | N_Op_Ne then Error_Msg_N ("ambiguous operands for equality", N); else @@ -1063,8 +1063,8 @@ package body Sem_Ch4 is -- performing the writable actuals check. if Has_Arbitrary_Evaluation_Order (Nkind (P)) - and then not Nkind_In (P, N_Assignment_Statement, - N_Object_Declaration) + and then Nkind (P) not in + N_Assignment_Statement | N_Object_Declaration then Outermost := P; end if; @@ -1073,8 +1073,8 @@ package body Sem_Ch4 is exit when Stop_Subtree_Climbing (Nkind (P)) or else (Nkind (P) = N_Range - and then not - Nkind_In (Parent (P), N_In, N_Not_In)); + and then + Nkind (Parent (P)) not in N_In | N_Not_In); P := Parent (P); end loop; @@ -1124,8 +1124,7 @@ package body Sem_Ch4 is -- Check for tasking cases where only an entry call will do elsif not L - and then Nkind_In (K, N_Entry_Call_Alternative, - N_Triggering_Alternative) + and then K in N_Entry_Call_Alternative | N_Triggering_Alternative then Error_Msg_N ("entry name expected", Nam); @@ -1185,10 +1184,10 @@ package body Sem_Ch4 is elsif Nkind (Nam) = N_Selected_Component then Nam_Ent := Entity (Selector_Name (Nam)); - if not Ekind_In (Nam_Ent, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure) + if Ekind (Nam_Ent) not in E_Entry + | E_Entry_Family + | E_Function + | E_Procedure then Error_Msg_N ("name in call is not a callable entity", Nam); Set_Etype (N, Any_Type); @@ -1363,7 +1362,7 @@ package body Sem_Ch4 is Set_Etype (Nam, It.Typ); end if; - elsif Nkind_In (Name (N), N_Function_Call, N_Selected_Component) + elsif Nkind (Name (N)) in N_Function_Call | N_Selected_Component then Remove_Interp (X); end if; @@ -3786,9 +3785,9 @@ package body Sem_Ch4 is -- Verify Nam is a non-visible controlled primitive - and then Nam_In (Chars (Nam), Name_Adjust, - Name_Finalize, - Name_Initialize) + and then Chars (Nam) in Name_Adjust + | Name_Finalize + | Name_Initialize and then Ekind (Nam) = E_Procedure and then Is_Controlled (Etype (First_Form)) and then No (Next_Formal (First_Form)) @@ -4014,14 +4013,15 @@ package body Sem_Ch4 is Find_Type (Mark); T := Entity (Mark); - if Nkind_In (Enclosing_Declaration (N), N_Formal_Type_Declaration, - N_Full_Type_Declaration, - N_Incomplete_Type_Declaration, - N_Protected_Type_Declaration, - N_Private_Extension_Declaration, - N_Private_Type_Declaration, - N_Subtype_Declaration, - N_Task_Type_Declaration) + if Nkind (Enclosing_Declaration (N)) in + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Protected_Type_Declaration | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Subtype_Declaration | + N_Task_Type_Declaration and then T = Defining_Identifier (Enclosing_Declaration (N)) then Error_Msg_N ("current instance not allowed", Mark); @@ -4476,6 +4476,13 @@ package body Sem_Ch4 is -- Check whether prefix includes a dereference, explicit or implicit, -- at any recursive level. + function Try_By_Protected_Procedure_Prefixed_View return Boolean; + -- Return True if N is an access attribute whose prefix is a prefixed + -- class-wide (synchronized or protected) interface view for which some + -- interpretation is a procedure with synchronization kind By_Protected + -- _Procedure, and collect all its interpretations (since it may be an + -- overloaded interface primitive); otherwise return False. + -------------------------------- -- Find_Component_In_Instance -- -------------------------------- @@ -4589,7 +4596,7 @@ package body Sem_Ch4 is elsif Is_Access_Type (Etype (Nod)) then return True; - elsif Nkind_In (Nod, N_Indexed_Component, N_Selected_Component) then + elsif Nkind (Nod) in N_Indexed_Component | N_Selected_Component then return Has_Dereference (Prefix (Nod)); else @@ -4597,6 +4604,65 @@ package body Sem_Ch4 is end if; end Has_Dereference; + ---------------------------------------------- + -- Try_By_Protected_Procedure_Prefixed_View -- + ---------------------------------------------- + + function Try_By_Protected_Procedure_Prefixed_View return Boolean is + Candidate : Node_Id := Empty; + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + if Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) in + Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access + and then Is_Class_Wide_Type (Prefix_Type) + and then (Is_Synchronized_Interface (Prefix_Type) + or else Is_Protected_Interface (Prefix_Type)) + then + -- If we have not found yet any interpretation then mark this + -- one as the first interpretation (cf. Add_One_Interp). + + if No (Etype (Sel)) then + Set_Etype (Sel, Any_Type); + end if; + + Elmt := First_Elmt (Primitive_Operations (Etype (Prefix_Type))); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Chars (Prim) = Chars (Sel) + and then Is_By_Protected_Procedure (Prim) + then + Candidate := New_Copy (Prim); + + -- Skip the controlling formal; required to check type + -- conformance of the target access to protected type + -- (see Conforming_Types). + + Set_First_Entity (Candidate, + Next_Entity (First_Entity (Prim))); + + Add_One_Interp (Sel, Candidate, Etype (Prim)); + Set_Etype (N, Etype (Prim)); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Propagate overloaded attribute + + if Present (Candidate) and then Is_Overloaded (Sel) then + Set_Is_Overloaded (N); + end if; + + return Present (Candidate); + end Try_By_Protected_Procedure_Prefixed_View; + -- Start of processing for Analyze_Selected_Component begin @@ -4807,10 +4873,10 @@ package body Sem_Ch4 is or else (Nkind (Parent_N) = N_Attribute_Reference and then - Nam_In (Attribute_Name (Parent_N), Name_First, - Name_Last, - Name_Length, - Name_Range))) + Attribute_Name (Parent_N) in Name_First + | Name_Last + | Name_Length + | Name_Range)) then Set_Etype (N, Etype (Comp)); @@ -4892,6 +4958,9 @@ package body Sem_Ch4 is return; end if; + elsif Try_By_Protected_Procedure_Prefixed_View then + return; + elsif Try_Object_Operation (N) then return; end if; @@ -4988,9 +5057,9 @@ package body Sem_Ch4 is -- a visible entity is found. if Is_Tagged_Type (Prefix_Type) - and then Nkind_In (Parent (N), N_Function_Call, - N_Indexed_Component, - N_Procedure_Call_Statement) + and then Nkind (Parent (N)) in N_Function_Call + | N_Indexed_Component + | N_Procedure_Call_Statement and then Has_Mode_Conformant_Spec (Comp) then Has_Candidate := True; @@ -4999,7 +5068,7 @@ package body Sem_Ch4 is -- Note: a selected component may not denote a component of a -- protected type (4.1.3(7)). - elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family) + elsif Ekind (Comp) in E_Discriminant | E_Entry_Family or else (In_Scope and then not Is_Protected_Type (Prefix_Type) and then Is_Entity_Name (Name)) @@ -5588,9 +5657,9 @@ package body Sem_Ch4 is end if; elsif Nkind (Expr) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Expr), Name_Access, - Name_Unchecked_Access, - Name_Unrestricted_Access) + and then Attribute_Name (Expr) in Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access then Error_Msg_N ("argument of conversion cannot be access", N); Error_Msg_N ("\use qualified expression instead", N); @@ -5852,7 +5921,7 @@ package body Sem_Ch4 is -- Start of processing for Check_Arithmetic_Pair begin - if Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then + if Op_Name in Name_Op_Add | Name_Op_Subtract then if Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) and then (Covers (T1 => T1, T2 => T2) @@ -5862,7 +5931,7 @@ package body Sem_Ch4 is Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; - elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) then + elsif Op_Name in Name_Op_Multiply | Name_Op_Divide then if Is_Fixed_Point_Type (T1) and then (Is_Fixed_Point_Type (T2) or else T2 = Universal_Real) then @@ -6160,7 +6229,7 @@ package body Sem_Ch4 is else while Present (It.Nam) loop - if Ekind_In (It.Nam, E_Function, E_Operator) then + if Ekind (It.Nam) in E_Function | E_Operator then return; else Get_Next_Interp (X, It); @@ -6588,9 +6657,7 @@ package body Sem_Ch4 is procedure Check_Access_Attribute (N : Node_Id) is begin if Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), - Name_Access, - Name_Unchecked_Access) + and then Attribute_Name (N) in Name_Access | Name_Unchecked_Access then Error_Msg_N ("access attribute cannot be used as actual for " @@ -7332,7 +7399,7 @@ package body Sem_Ch4 is -- pretty much know that the other operand should be Boolean, so -- resolve it that way (generating an error). - elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then + elsif Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor then if Etype (L) = Standard_Boolean then Resolve (R, Standard_Boolean); return; @@ -7346,16 +7413,16 @@ package body Sem_Ch4 is -- is not the same numeric type. If it is a non-numeric type, -- then probably it is intended to match the other operand. - elsif Nkind_In (N, N_Op_Add, - N_Op_Divide, - N_Op_Ge, - N_Op_Gt, - N_Op_Le, - N_Op_Lt, - N_Op_Mod, - N_Op_Multiply, - N_Op_Rem, - N_Op_Subtract) + elsif Nkind (N) in N_Op_Add + | N_Op_Divide + | N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + | N_Op_Mod + | N_Op_Multiply + | N_Op_Rem + | N_Op_Subtract then -- If Allow_Integer_Address is active, check whether the -- operation becomes legal after converting an operand. @@ -7371,7 +7438,7 @@ package body Sem_Ch4 is Unchecked_Convert_To ( Standard_Address, Relocate_Node (R))); - if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then + if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then Analyze_Comparison_Op (N); else Analyze_Arithmetic_Op (N); @@ -7393,7 +7460,7 @@ package body Sem_Ch4 is Unchecked_Convert_To ( Standard_Address, Relocate_Node (R))); - if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then + if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then Analyze_Comparison_Op (N); else Analyze_Arithmetic_Op (N); @@ -7423,7 +7490,7 @@ package body Sem_Ch4 is Unchecked_Convert_To ( Standard_Address, Relocate_Node (R))); - if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then + if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then Analyze_Comparison_Op (N); else Analyze_Arithmetic_Op (N); @@ -7447,7 +7514,7 @@ package body Sem_Ch4 is elsif Null_To_Null_Address_Convert_OK (N) then Replace_Null_By_Null_Address (N); - if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then + if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then Analyze_Comparison_Op (N); else Analyze_Arithmetic_Op (N); @@ -7459,7 +7526,7 @@ package body Sem_Ch4 is -- Comparisons on A'Access are common enough to deserve a -- special message. - elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) + elsif Nkind (N) in N_Op_Eq | N_Op_Ne and then Ekind (Etype (L)) = E_Access_Attribute_Type and then Ekind (Etype (R)) = E_Access_Attribute_Type then @@ -7517,7 +7584,7 @@ package body Sem_Ch4 is return; - elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then + elsif Nkind (N) in N_Op_Eq | N_Op_Ne then if Address_Integer_Convert_OK (Etype (R), Etype (L)) then Rewrite (L, Unchecked_Convert_To ( @@ -7608,7 +7675,7 @@ package body Sem_Ch4 is -- indicate that the integer operand should be of -- type Integer. - if Nkind_In (N, N_Op_Multiply, N_Op_Divide) + if Nkind (N) in N_Op_Multiply | N_Op_Divide and then Is_Fixed_Point_Type (Etype (L)) and then Is_Integer_Type (Etype (R)) then @@ -7910,7 +7977,7 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean is - Pref_Typ : constant Entity_Id := Etype (Prefix); + Pref_Typ : Entity_Id := Etype (Prefix); function Constant_Indexing_OK return Boolean; -- Constant_Indexing is legal if there is no Variable_Indexing defined @@ -7961,8 +8028,8 @@ package body Sem_Ch4 is -- resolution does not depend on the type of the parameter that -- includes the indexing operation. - elsif Nkind_In (Parent (Par), N_Function_Call, - N_Procedure_Call_Statement) + elsif Nkind (Parent (Par)) in + N_Function_Call | N_Procedure_Call_Statement and then Is_Entity_Name (Name (Parent (Par))) then declare @@ -8346,6 +8413,25 @@ package body Sem_Ch4 is return True; end if; + -- An explicit dereference needs to be created in the case of a prefix + -- that's an access. + + -- It seems that this should be done elsewhere, but not clear where that + -- should happen. Normally Insert_Explicit_Dereference is called via + -- Resolve_Implicit_Dereference, called from Resolve_Indexed_Component, + -- but that won't be called in this case because we transform the + -- indexing to a call. Resolve_Call.Check_Prefixed_Call takes care of + -- implicit dereferencing and referencing on prefixed calls, but that + -- would be too late, even if we expanded to a prefix call, because + -- Process_Indexed_Component will flag an error before the resolution + -- happens. ??? + + if Is_Access_Type (Pref_Typ) then + Pref_Typ := Implicitly_Designated_Type (Pref_Typ); + Insert_Explicit_Dereference (Prefix); + Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); + end if; + C_Type := Pref_Typ; -- If indexing a class-wide container, obtain indexing primitive from @@ -9178,7 +9264,7 @@ package body Sem_Ch4 is Hom := Current_Entity (Subprog); while Present (Hom) loop - if Ekind_In (Hom, E_Procedure, E_Function) + if Ekind (Hom) in E_Procedure | E_Function and then Present (Renamed_Entity (Hom)) and then Is_Generic_Actual_Subprogram (Hom) and then In_Open_Scopes (Scope (Hom)) @@ -9188,7 +9274,7 @@ package body Sem_Ch4 is Candidate := Hom; end if; - if Ekind_In (Candidate, E_Function, E_Procedure) + if Ekind (Candidate) in E_Function | E_Procedure and then (not Is_Hidden (Candidate) or else In_Instance) and then Scope (Candidate) = Scope (Base_Type (Anc_Type)) and then First_Formal_Match (Candidate, CW_Typ) @@ -9366,8 +9452,8 @@ package body Sem_Ch4 is Obj_Type := Designated_Type (Obj_Type); end if; - if Ekind_In (Obj_Type, E_Private_Subtype, - E_Record_Subtype_With_Private) + if Ekind (Obj_Type) + in E_Private_Subtype | E_Record_Subtype_With_Private then Obj_Type := Base_Type (Obj_Type); end if; @@ -9537,7 +9623,7 @@ package body Sem_Ch4 is if Is_Derived_Type (T) then return Primitive_Operations (T); - elsif Ekind_In (Scope (T), E_Procedure, E_Function) then + elsif Ekind (Scope (T)) in E_Procedure | E_Function then -- Scan the list of generic formals to find subprograms -- that may have a first controlling formal of the type. diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 74ebc6a..336507a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -305,9 +305,8 @@ package body Sem_Ch5 is if Is_Entity_Name (Opnd) and then (Ekind (Entity (Opnd)) = E_Out_Parameter - or else Ekind_In (Entity (Opnd), - E_In_Out_Parameter, - E_Generic_In_Out_Parameter) + or else Ekind (Entity (Opnd)) in + E_In_Out_Parameter | E_Generic_In_Out_Parameter or else (Ekind (Entity (Opnd)) = E_Variable and then Nkind (Parent (Entity (Opnd))) = @@ -320,7 +319,7 @@ package body Sem_Ch5 is -- If assignment operand is a component reference, then we get the -- actual subtype of the component for the unconstrained case. - elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference) + elsif Nkind (Opnd) in N_Selected_Component | N_Explicit_Dereference and then not Is_Unchecked_Union (Opnd_Type) then Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); @@ -825,7 +824,7 @@ package body Sem_Ch5 is and then Is_Assignable (Entity (Lhs)) and then Is_Composite_Type (T1) and then not Is_Constrained (Etype (Entity (Lhs))) - and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression) + and then Nkind (Rhs) in N_If_Expression | N_Case_Expression then Resolve (Rhs, Base_Type (T1)); @@ -1239,7 +1238,7 @@ package body Sem_Ch5 is -- Do not install the return object - if not Ekind_In (Id, E_Constant, E_Variable) + if Ekind (Id) not in E_Constant | E_Variable or else not Is_Return_Object (Id) then Install_Entity (Id); @@ -1473,9 +1472,7 @@ package body Sem_Ch5 is if Is_Entity_Name (Exp) then Ent := Entity (Exp); - if Ekind_In (Ent, E_Variable, - E_In_Out_Parameter, - E_Out_Parameter) + if Ekind (Ent) in E_Variable | E_In_Out_Parameter | E_Out_Parameter then if List_Length (Choices) = 1 and then Nkind (First (Choices)) in N_Subexpr @@ -1752,7 +1749,8 @@ package body Sem_Ch5 is Scope_Id := Scope_Stack.Table (J).Entity; if Label_Scope = Scope_Id - or else not Ekind_In (Scope_Id, E_Block, E_Loop, E_Return_Statement) + or else Ekind (Scope_Id) not in + E_Block | E_Loop | E_Return_Statement then if Scope_Id /= Label_Scope then Error_Msg_N @@ -2522,10 +2520,9 @@ package body Sem_Ch5 is if Nkind (Orig_Iter_Name) = N_Selected_Component and then Present (Entity (Selector_Name (Orig_Iter_Name))) - and then Ekind_In - (Entity (Selector_Name (Orig_Iter_Name)), - E_Component, - E_Discriminant) + and then + Ekind (Entity (Selector_Name (Orig_Iter_Name))) in + E_Component | E_Discriminant and then Is_Dependent_Component_Of_Mutable_Object (Orig_Iter_Name) then @@ -2803,8 +2800,8 @@ package body Sem_Ch5 is if Analyzed (Original_Bound) then return Original_Bound; - elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, - N_Character_Literal) + elsif Nkind (Analyzed_Bound) in + N_Integer_Literal | N_Character_Literal or else Is_Entity_Name (Analyzed_Bound) then Analyze_And_Resolve (Original_Bound, Typ); @@ -3002,8 +2999,8 @@ package body Sem_Ch5 is and then not Is_Type (Entity (DS_Copy))) or else (Nkind (DS_Copy) = N_Attribute_Reference - and then Nam_In (Attribute_Name (DS_Copy), - Name_Loop_Entry, Name_Old)) + and then Attribute_Name (DS_Copy) in + Name_Loop_Entry | Name_Old) or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable) @@ -3143,7 +3140,7 @@ package body Sem_Ch5 is -- Case where we have a range or a subtype, get type bounds - if Nkind_In (DS, N_Range, N_Subtype_Indication) + if Nkind (DS) in N_Range | N_Subtype_Indication and then not Error_Posted (DS) and then Etype (DS) /= Any_Type and then Is_Discrete_Type (Etype (DS)) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index fb14cbd..ed1c326 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -580,7 +580,7 @@ package body Sem_Ch6 is -- requirements of the Ada 202x RM in 4.9(3.2/5-3.4/5) and -- we flag an error. - if Is_Static_Expression_Function (Def_Id) then + if Is_Static_Function (Def_Id) then if not Is_Static_Expression (Expr) then declare Exp_Copy : constant Node_Id := New_Copy_Tree (Expr); @@ -760,8 +760,8 @@ package body Sem_Ch6 is elsif Kind = N_Function_Call and then Is_Entity_Name (Name (Return_Expr)) - and then Ekind_In (Entity (Name (Return_Expr)), E_Function, - E_Generic_Function) + and then Ekind (Entity (Name (Return_Expr))) in + E_Function | E_Generic_Function and then No_Return (Entity (Name (Return_Expr))) then return; @@ -801,8 +801,8 @@ package body Sem_Ch6 is -- We are only interested in return statements - if not Nkind_In (Return_Stmt, N_Extended_Return_Statement, - N_Simple_Return_Statement) + if Nkind (Return_Stmt) not in + N_Extended_Return_Statement | N_Simple_Return_Statement then return; end if; @@ -884,8 +884,8 @@ package body Sem_Ch6 is if Nkind (Assoc) = N_Attribute_Reference then Expr := Assoc; - elsif Nkind_In (Assoc, N_Component_Association, - N_Discriminant_Association) + elsif Nkind (Assoc) in + N_Component_Association | N_Discriminant_Association then Expr := Expression (Assoc); else @@ -904,11 +904,16 @@ package body Sem_Ch6 is -- named access types and renamed objects within the -- expression. + -- Note, this loop duplicates some of the logic in + -- Object_Access_Level since we have to check special rules + -- based on the context we are in (a return aggregate) + -- relating to formals of the current function. + Obj := Original_Node (Prefix (Expr)); loop - while Nkind_In (Obj, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component) + while Nkind (Obj) in N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component loop -- When we encounter a named access type then we can -- ignore accessibility checks on the dereference. @@ -943,15 +948,20 @@ package body Sem_Ch6 is end if; end loop; - -- Do not check aliased formals or function calls. A - -- run-time check may still be needed ??? + -- Do not check aliased formals statically if Is_Formal (Entity (Obj)) - and then Is_Aliased (Entity (Obj)) + and then (Is_Aliased (Entity (Obj)) + or else Ekind (Etype (Entity (Obj))) = + E_Anonymous_Access_Type) then null; - elsif Object_Access_Level (Obj) > + -- Otherwise, handle the expression normally, avoiding the + -- special logic above, and call Object_Access_Level with + -- the original expression. + + elsif Object_Access_Level (Expr) > Scope_Depth (Scope (Scope_Id)) then Error_Msg_N @@ -1146,8 +1156,7 @@ package body Sem_Ch6 is -- This early expansion is done only when the return statement is -- not part of a handled sequence of statements. - if Nkind_In (Expr, N_Aggregate, - N_Extension_Aggregate) + if Nkind (Expr) in N_Aggregate | N_Extension_Aggregate and then Needs_Finalization (R_Type) and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements then @@ -1179,7 +1188,7 @@ package body Sem_Ch6 is if Expander_Active and then Serious_Errors_Detected = 0 and then Is_Access_Type (R_Type) - and then not Nkind_In (Expr, N_Null, N_Raise_Expression) + and then Nkind (Expr) not in N_Null | N_Raise_Expression and then Is_Interface (Designated_Type (R_Type)) and then Is_Progenitor (Designated_Type (R_Type), Designated_Type (Etype (Expr))) @@ -1239,7 +1248,7 @@ package body Sem_Ch6 is and then not Is_Constrained (R_Type) and then Is_Build_In_Place_Function (Scope_Id) and then Needs_BIP_Alloc_Form (Scope_Id) - and then Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) + and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate then Preanalyze (Obj_Decl); @@ -1986,9 +1995,9 @@ package body Sem_Ch6 is -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls if Nkind (P) = N_Attribute_Reference - and then Nam_In (Attribute_Name (P), Name_Elab_Spec, - Name_Elab_Body, - Name_Elab_Subp_Body) + and then Attribute_Name (P) in Name_Elab_Spec + | Name_Elab_Body + | Name_Elab_Subp_Body then if Present (Actuals) then Error_Msg_N @@ -2014,6 +2023,10 @@ package body Sem_Ch6 is and then Comes_From_Source (N) then Error_Msg_N ("missing explicit dereference in call", N); + + elsif Ekind (Entity (P)) = E_Operator then + Error_Msg_Name_1 := Chars (P); + Error_Msg_N ("operator % cannot be used as a procedure", N); end if; Analyze_Call_And_Resolve; @@ -2074,9 +2087,8 @@ package body Sem_Ch6 is -- function, the context will select the operation whose type is Void. elsif Nkind (P) = N_Selected_Component - and then Ekind_In (Entity (Selector_Name (P)), E_Entry, - E_Function, - E_Procedure) + and then Ekind (Entity (Selector_Name (P))) + in E_Entry | E_Function | E_Procedure then -- When front-end inlining is enabled, as with SPARK_Mode, a call -- in prefix notation may still be missing its controlling argument, @@ -2175,8 +2187,8 @@ package body Sem_Ch6 is ------------------------------ procedure Analyze_Return_Statement (N : Node_Id) is - pragma Assert (Nkind_In (N, N_Extended_Return_Statement, - N_Simple_Return_Statement)); + pragma Assert + (Nkind (N) in N_Extended_Return_Statement | N_Simple_Return_Statement); Returns_Object : constant Boolean := Nkind (N) = N_Extended_Return_Statement @@ -2209,7 +2221,7 @@ package body Sem_Ch6 is for J in reverse 0 .. Scope_Stack.Last loop Result := Scope_Stack.Table (J).Entity; - exit when not Ekind_In (Result, E_Block, E_Loop) + exit when Ekind (Result) not in E_Block | E_Loop and then Chars (Result) /= Name_uPostconditions; end loop; @@ -2245,7 +2257,7 @@ package body Sem_Ch6 is -- implicitly-generated return that is placed at the end. if No_Return (Scope_Id) - and then Ekind_In (Kind, E_Procedure, E_Generic_Procedure) + and then Kind in E_Procedure | E_Generic_Procedure and then Comes_From_Source (N) then Error_Msg_N @@ -2260,17 +2272,17 @@ package body Sem_Ch6 is -- Check that functions return objects, and other things do not - if Ekind_In (Kind, E_Function, E_Generic_Function) then + if Kind in E_Function | E_Generic_Function then if not Returns_Object then Error_Msg_N ("missing expression in return from function", N); end if; - elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then + elsif Kind in E_Procedure | E_Generic_Procedure then if Returns_Object then Error_Msg_N ("procedure cannot return value (use function)", N); end if; - elsif Ekind_In (Kind, E_Entry, E_Entry_Family) then + elsif Kind in E_Entry | E_Entry_Family then if Returns_Object then if Is_Protected_Type (Scope (Scope_Id)) then Error_Msg_N ("entry body cannot return value", N); @@ -2304,10 +2316,10 @@ package body Sem_Ch6 is Error_Msg_N ("illegal context for return statement", N); end if; - if Ekind_In (Kind, E_Function, E_Generic_Function) then + if Kind in E_Function | E_Generic_Function then Analyze_Function_Return (N); - elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then + elsif Kind in E_Procedure | E_Generic_Procedure then Set_Return_Present (Scope_Id); end if; @@ -2472,8 +2484,8 @@ package body Sem_Ch6 is null; elsif Nkind (Parent (N)) = N_Subprogram_Body - or else Nkind_In (Parent (Parent (N)), N_Accept_Statement, - N_Entry_Body) + or else Nkind (Parent (Parent (N))) in + N_Accept_Statement | N_Entry_Body then Error_Msg_NE ("invalid use of untagged incomplete type&", @@ -3047,8 +3059,8 @@ package body Sem_Ch6 is -- the environment task is our effective master, so nothing -- to mark. - if Nkind_In - (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) + if Nkind (Par) + in N_Task_Body | N_Block_Statement | N_Subprogram_Body then Set_Is_Task_Master (Par, True); exit; @@ -3401,7 +3413,7 @@ package body Sem_Ch6 is -- Do not process subprogram bodies as they already use the non- -- limited view of types. - if not Ekind_In (Subp_Id, E_Function, E_Procedure) then + if Ekind (Subp_Id) not in E_Function | E_Procedure then return No_Elist; end if; @@ -3504,11 +3516,11 @@ package body Sem_Ch6 is if Is_Entity_Name (Node) and then Present (Entity (Node)) then Mask_Type (Etype (Entity (Node))); - if Ekind_In (Entity (Node), E_Component, E_Discriminant) then + if Ekind (Entity (Node)) in E_Component | E_Discriminant then Mask_Type (Scope (Entity (Node))); end if; - elsif Nkind_In (Node, N_Aggregate, N_Null, N_Type_Conversion) + elsif Nkind (Node) in N_Aggregate | N_Null | N_Type_Conversion and then Present (Etype (Node)) then Mask_Type (Etype (Node)); @@ -3571,19 +3583,18 @@ package body Sem_Ch6 is -- Move relevant pragmas to the spec - elsif Nam_In (Pragma_Name_Unmapped (Decl), - Name_Depends, - Name_Ghost, - Name_Global, - Name_Pre, - Name_Precondition, - Name_Post, - Name_Refined_Depends, - Name_Refined_Global, - Name_Refined_Post, - Name_Inline, - Name_Pure_Function, - Name_Volatile_Function) + elsif Pragma_Name_Unmapped (Decl) in Name_Depends + | Name_Ghost + | Name_Global + | Name_Pre + | Name_Precondition + | Name_Post + | Name_Refined_Depends + | Name_Refined_Global + | Name_Refined_Post + | Name_Inline + | Name_Pure_Function + | Name_Volatile_Function then Remove (Decl); Insert_After (Insert_Nod, Decl); @@ -3679,9 +3690,9 @@ package body Sem_Ch6 is -- expansion. As a result, we add an exception for this case. elsif not Present (Overridden_Operation (Spec_Id)) - and then not (Nam_In (Chars (Spec_Id), Name_Adjust, - Name_Finalize, - Name_Initialize) + and then not (Chars (Spec_Id) in Name_Adjust + | Name_Finalize + | Name_Initialize and then In_Instance) then Error_Msg_NE @@ -4981,9 +4992,7 @@ package body Sem_Ch6 is -- Push_xxx_Error_Label to find the first real statement. Stm := First (Statements (HSS)); - while Nkind_In (Stm, N_Call_Marker, N_Label) - or else Nkind (Stm) in N_Push_xxx_Label - loop + while Nkind (Stm) in N_Call_Marker | N_Label | N_Push_xxx_Label loop Next (Stm); end loop; @@ -5539,10 +5548,10 @@ package body Sem_Ch6 is -- In case of primitives associated with abstract interface types -- the check is applied later (see Analyze_Subprogram_Declaration). - if not Nkind_In (Original_Node (Parent (N)), - N_Abstract_Subprogram_Declaration, - N_Formal_Abstract_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + if Nkind (Original_Node (Parent (N))) not in + N_Abstract_Subprogram_Declaration | + N_Formal_Abstract_Subprogram_Declaration | + N_Subprogram_Renaming_Declaration then if Is_Abstract_Type (Etype (Designator)) then Error_Msg_N @@ -5591,10 +5600,11 @@ package body Sem_Ch6 is -- in the message, and also provides the location for posting the -- message in the absence of a specified Err_Loc location. - function Conventions_Match - (Id1 : Entity_Id; - Id2 : Entity_Id) return Boolean; - -- Determine whether the conventions of arbitrary entities Id1 and Id2 + function Conventions_Match (Id1, Id2 : Entity_Id) return Boolean; + -- True if the conventions of entities Id1 and Id2 match. + + function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean; + -- True if the null exclusions of two formals of anonymous access type -- match. ----------------------- @@ -5670,11 +5680,11 @@ package body Sem_Ch6 is -- the only way these may receive a convention is if they inherit -- the convention of a related subprogram. - if Ekind_In (Id1, E_Anonymous_Access_Subprogram_Type, - E_Subprogram_Type) + if Ekind (Id1) in E_Anonymous_Access_Subprogram_Type + | E_Subprogram_Type or else - Ekind_In (Id2, E_Anonymous_Access_Subprogram_Type, - E_Subprogram_Type) + Ekind (Id2) in E_Anonymous_Access_Subprogram_Type + | E_Subprogram_Type then return True; @@ -5685,6 +5695,50 @@ package body Sem_Ch6 is end if; end Conventions_Match; + --------------------------- + -- Null_Exclusions_Match -- + --------------------------- + + function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean is + begin + if not Is_Anonymous_Access_Type (Etype (F1)) + or else not Is_Anonymous_Access_Type (Etype (F2)) + then + return True; + end if; + + -- AI12-0289-1: Case of controlling access parameter; False if the + -- partial view is untagged, the full view is tagged, and no explicit + -- "not null". Note that at this point, we're processing the package + -- body, so private/full types have been swapped. The Sloc test below + -- is to detect the (legal) case where F1 comes after the full type + -- declaration. This part is disabled pre-2005, because "not null" is + -- not allowed on those language versions. + + if Ada_Version >= Ada_2005 + and then Is_Controlling_Formal (F1) + and then not Null_Exclusion_Present (Parent (F1)) + and then not Null_Exclusion_Present (Parent (F2)) + then + declare + D : constant Entity_Id := Directly_Designated_Type (Etype (F1)); + Partial_View_Of_Desig : constant Entity_Id := + Incomplete_Or_Partial_View (D); + begin + return No (Partial_View_Of_Desig) + or else Is_Tagged_Type (Partial_View_Of_Desig) + or else Sloc (D) < Sloc (F1); + end; + + -- Not a controlling parameter, or one or both views have an explicit + -- "not null". + + else + return Null_Exclusion_Present (Parent (F1)) = + Null_Exclusion_Present (Parent (F2)); + end if; + end Null_Exclusions_Match; + -- Local Variables Old_Type : constant Entity_Id := Etype (Old_Id); @@ -5854,25 +5908,14 @@ package body Sem_Ch6 is -- Null exclusion must match - if Null_Exclusion_Present (Parent (Old_Formal)) - /= - Null_Exclusion_Present (Parent (New_Formal)) - then - -- Only give error if both come from source. This should be - -- investigated some time, since it should not be needed ??? - - if Comes_From_Source (Old_Formal) - and then - Comes_From_Source (New_Formal) - then - Conformance_Error - ("\null exclusion for& does not match", New_Formal); + if not Null_Exclusions_Match (Old_Formal, New_Formal) then + Conformance_Error + ("\null exclusion for& does not match", New_Formal); - -- Mark error posted on the new formal to avoid duplicated - -- complaint about types not matching. + -- Mark error posted on the new formal to avoid duplicated + -- complaint about types not matching. - Set_Error_Posted (New_Formal); - end if; + Set_Error_Posted (New_Formal); end if; end if; @@ -5949,7 +5992,7 @@ package body Sem_Ch6 is if Ctype >= Mode_Conformant then if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then - if not Ekind_In (New_Id, E_Function, E_Procedure) + if Ekind (New_Id) not in E_Function | E_Procedure or else not Is_Primitive_Wrapper (New_Id) then Conformance_Error ("\mode of & does not match!", New_Formal); @@ -6718,11 +6761,11 @@ package body Sem_Ch6 is Decl := Unit_Declaration_Node (Subp); end if; - if Nkind_In (Decl, N_Subprogram_Body, - N_Subprogram_Body_Stub, - N_Subprogram_Declaration, - N_Abstract_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + if Nkind (Decl) in N_Subprogram_Body + | N_Subprogram_Body_Stub + | N_Subprogram_Declaration + | N_Abstract_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration then Spec := Specification (Decl); @@ -6818,9 +6861,9 @@ package body Sem_Ch6 is if Present (Overridden_Subp) and then (not Is_Hidden (Overridden_Subp) or else - (Nam_In (Chars (Overridden_Subp), Name_Initialize, - Name_Adjust, - Name_Finalize) + (Chars (Overridden_Subp) in Name_Initialize + | Name_Adjust + | Name_Finalize and then Present (Alias (Overridden_Subp)) and then (not Is_Hidden (Alias (Overridden_Subp)) or else In_Instance))) @@ -7122,12 +7165,10 @@ package body Sem_Ch6 is -- Don't count exception junk or else - (Nkind_In (Last_Stm, N_Goto_Statement, - N_Label, - N_Object_Declaration) + (Nkind (Last_Stm) in + N_Goto_Statement | N_Label | N_Object_Declaration and then Exception_Junk (Last_Stm)) - or else Nkind (Last_Stm) in N_Push_xxx_Label - or else Nkind (Last_Stm) in N_Pop_xxx_Label + or else Nkind (Last_Stm) in N_Push_xxx_Label | N_Pop_xxx_Label -- Inserted code, such as finalization calls, is irrelevant: we only -- need to check original source. @@ -7555,7 +7596,7 @@ package body Sem_Ch6 is function Is_Valid_Formal (F : Entity_Id) return Boolean is begin return - Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter) + Ekind (F) in E_In_Out_Parameter | E_Out_Parameter or else (Nkind (Parameter_Type (Parent (F))) = N_Access_Definition and then not Constant_Present (Parameter_Type (Parent (F)))); @@ -7792,7 +7833,7 @@ package body Sem_Ch6 is -- Entries and procedures can override abstract or null interface -- procedures. - elsif Ekind_In (Def_Id, E_Entry, E_Procedure) + elsif Ekind (Def_Id) in E_Entry | E_Procedure and then Ekind (Subp) = E_Procedure and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), @@ -7812,7 +7853,7 @@ package body Sem_Ch6 is -- override, the first parameter of the overridden routine -- must be of mode "out", "in out", or access-to-variable. - if Ekind_In (Candidate, E_Entry, E_Procedure) + if Ekind (Candidate) in E_Entry | E_Procedure and then Is_Protected_Type (Typ) and then not Is_Valid_Formal (Formal) then @@ -8218,11 +8259,11 @@ package body Sem_Ch6 is -- or both could be access to protected subprograms. Are_Anonymous_Access_To_Subprogram_Types := - Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type) + Ekind (Type_1) in E_Anonymous_Access_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type and then - Ekind_In (Type_2, E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type); + Ekind (Type_2) in E_Anonymous_Access_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type; -- Test anonymous access type case. For this case, static subtype -- matching is required for mode conformance (RM 6.3.1(15)). We check @@ -8684,8 +8725,8 @@ package body Sem_Ch6 is -- to this are inherited operations from a parent type in which -- case the derived type acts as their parent. - if Nkind_In (Subp_Decl, N_Function_Specification, - N_Procedure_Specification) + if Nkind (Subp_Decl) in N_Function_Specification + | N_Procedure_Specification then Subp_Decl := Parent (Subp_Decl); end if; @@ -9211,8 +9252,8 @@ package body Sem_Ch6 is -- conformant with it. That can occur in cases where an -- actual type causes unrelated homographs in the instance. - if Nkind_In (N, N_Subprogram_Body, - N_Subprogram_Renaming_Declaration) + if Nkind (N) in N_Subprogram_Body + | N_Subprogram_Renaming_Declaration and then Present (Homonym (E)) and then not Fully_Conformant (Designator, E) then @@ -9487,9 +9528,10 @@ package body Sem_Ch6 is function User_Defined_Numeric_Literal_Mismatch return Boolean is E1_Is_User_Defined : constant Boolean := - not Nkind_In (Given_E1, N_Integer_Literal, N_Real_Literal); + Nkind (Given_E1) not in N_Integer_Literal | N_Real_Literal; E2_Is_User_Defined : constant Boolean := - not Nkind_In (Given_E2, N_Integer_Literal, N_Real_Literal); + Nkind (Given_E2) not in N_Integer_Literal | N_Real_Literal; + begin pragma Assert (E1_Is_User_Defined = E2_Is_User_Defined); @@ -10664,10 +10706,9 @@ package body Sem_Ch6 is H := Homonym (H); exit when not Present (H) or else Scope (H) /= Scope (S); - if Nkind_In - (Parent (H), - N_Private_Extension_Declaration, - N_Private_Type_Declaration) + if Nkind (Parent (H)) in + N_Private_Extension_Declaration | + N_Private_Type_Declaration and then Defining_Identifier (Parent (H)) = Partial_View then return True; @@ -11969,9 +12010,9 @@ package body Sem_Ch6 is and then not Is_Generic_Type (Formal_Type) and then not Is_Class_Wide_Type (Formal_Type) then - if not Nkind_In - (Parent (T), N_Access_Function_Definition, - N_Access_Procedure_Definition) + if Nkind (Parent (T)) not in + N_Access_Function_Definition | + N_Access_Procedure_Definition then Append_Elmt (Current_Scope, Private_Dependents (Base_Type (Formal_Type))); @@ -11988,8 +12029,8 @@ package body Sem_Ch6 is end if; end if; - elsif not Nkind_In (Parent (T), N_Access_Function_Definition, - N_Access_Procedure_Definition) + elsif Nkind (Parent (T)) not in N_Access_Function_Definition + | N_Access_Procedure_Definition then -- AI05-0151: Tagged incomplete types are allowed in all -- formal parts. Untagged incomplete types are not allowed @@ -12016,9 +12057,9 @@ package body Sem_Ch6 is then null; - elsif Nkind_In (Context, N_Accept_Statement, - N_Accept_Alternative, - N_Entry_Body) + elsif Nkind (Context) in N_Accept_Statement + | N_Accept_Alternative + | N_Entry_Body or else (Nkind (Context) = N_Subprogram_Body and then Comes_From_Source (Context)) then @@ -12196,12 +12237,12 @@ package body Sem_Ch6 is -- these are not standard Ada legality rules. if SPARK_Mode = On then - if Ekind_In (Scope (Formal), E_Function, E_Generic_Function) then + if Ekind (Scope (Formal)) in E_Function | E_Generic_Function then -- A function cannot have a parameter of mode IN OUT or OUT -- (SPARK RM 6.1). - if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then + if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then Error_Msg_N ("function cannot have parameter of mode `OUT` or " & "`IN OUT`", Formal); @@ -12524,7 +12565,7 @@ package body Sem_Ch6 is Set_Has_Out_Or_In_Out_Parameter (Id, True); end if; - if Ekind_In (Id, E_Function, E_Generic_Function) then + if Ekind (Id) in E_Function | E_Generic_Function then -- [IN] OUT parameters allowed for functions in Ada 2012 @@ -12706,12 +12747,12 @@ package body Sem_Ch6 is -- Verify that user-defined operators have proper number of arguments -- First case of operators which can only be unary - if Nam_In (Id, Name_Op_Not, Name_Op_Abs) then + if Id in Name_Op_Not | Name_Op_Abs then N_OK := (N = 1); -- Case of operators which can be unary or binary - elsif Nam_In (Id, Name_Op_Add, Name_Op_Subtract) then + elsif Id in Name_Op_Add | Name_Op_Subtract then N_OK := (N in 1 .. 2); -- All other operators can only be binary diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 51a245c..3ff2001 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -464,9 +464,9 @@ package body Sem_Ch7 is -- if they are not followed by a construct which can reference -- and export them. - elsif Nkind_In (Decl, N_Exception_Declaration, - N_Object_Declaration, - N_Object_Renaming_Declaration) + elsif Nkind (Decl) in N_Exception_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration then Decl_Id := Defining_Entity (Decl); @@ -483,8 +483,8 @@ package body Sem_Ch7 is -- for them to see whether they are referenced on an individual -- basis by looking into the table of referenced subprograms. - elsif Nkind_In (Decl, N_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + elsif Nkind (Decl) in N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration then Decl_Id := Defining_Entity (Decl); @@ -1370,8 +1370,8 @@ package body Sem_Ch7 is then Generate_Reference (Id, Scope (Id), 'k', False); - elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body, - N_Subunit) + elsif Nkind (Unit (Cunit (Main_Unit))) not in + N_Subprogram_Body | N_Subunit then -- If current unit is an ancestor of main unit, generate a -- reference to its own parent. @@ -1437,8 +1437,8 @@ package body Sem_Ch7 is -- prevents cascaded errors when routines defined only for type -- entities are called with non-type entities. - if Nkind_In (Decl, N_Incomplete_Type_Declaration, - N_Private_Type_Declaration) + if Nkind (Decl) in N_Incomplete_Type_Declaration + | N_Private_Type_Declaration and then Is_Type (Defining_Identifier (Decl)) and then Has_Discriminants (Defining_Identifier (Decl)) and then Present (Full_View (Defining_Identifier (Decl))) @@ -1472,8 +1472,8 @@ package body Sem_Ch7 is while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop Inst_Node := Get_Unit_Instantiation_Node (Inst_Par); - if Nkind_In (Inst_Node, N_Package_Instantiation, - N_Formal_Package_Declaration) + if Nkind (Inst_Node) in + N_Package_Instantiation | N_Formal_Package_Declaration and then Nkind (Name (Inst_Node)) = N_Expanded_Name then Inst_Par := Entity (Prefix (Name (Inst_Node))); @@ -2640,7 +2640,7 @@ package body Sem_Ch7 is -- implicit completion at some point. elsif (Is_Overloadable (Id) - and then not Ekind_In (Id, E_Enumeration_Literal, E_Operator) + and then Ekind (Id) not in E_Enumeration_Literal | E_Operator and then not Is_Abstract_Subprogram (Id) and then not Has_Completion (Id) and then Comes_From_Source (Parent (Id))) @@ -2657,7 +2657,7 @@ package body Sem_Ch7 is and then not Is_Generic_Type (Id)) or else - (Ekind_In (Id, E_Task_Type, E_Protected_Type) + (Ekind (Id) in E_Task_Type | E_Protected_Type and then not Has_Completion (Id)) or else @@ -2959,7 +2959,7 @@ package body Sem_Ch7 is Check_Conventions (Id); end if; - if Ekind_In (Id, E_Private_Type, E_Limited_Private_Type) + if Ekind (Id) in E_Private_Type | E_Limited_Private_Type and then No (Full_View (Id)) and then not Is_Generic_Type (Id) and then not Is_Derived_Type (Id) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index f23db52..3c10a96 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -780,7 +780,7 @@ package body Sem_Ch8 is Subt : Entity_Id; begin - if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference) + if Nkind (Nam) in N_Function_Call | N_Explicit_Dereference and then Is_Composite_Type (Typ) and then not Is_Constrained (Typ) and then not Has_Unknown_Discriminants (Typ) @@ -788,7 +788,7 @@ package body Sem_Ch8 is then -- If Actual_Subtype is already set, nothing to do - if Ekind_In (Id, E_Variable, E_Constant) + if Ekind (Id) in E_Variable | E_Constant and then Present (Actual_Subtype (Id)) then null; @@ -918,7 +918,8 @@ package body Sem_Ch8 is if No (Etype (Nam)) or else Etype (Nam) = Standard_Void_Type then - Error_Msg_N ("object name expected in renaming", Nam); + Error_Msg_N + ("object name or value expected in renaming", Nam); Set_Ekind (Id, E_Variable); Set_Etype (Id, Any_Type); @@ -965,7 +966,8 @@ package body Sem_Ch8 is -- as overloaded procedures named in the object renaming). if No (It.Typ) then - Error_Msg_N ("object name expected in renaming", Nam); + Error_Msg_N + ("object name or value expected in renaming", Nam); Set_Ekind (Id, E_Variable); Set_Etype (Id, Any_Type); @@ -996,6 +998,12 @@ package body Sem_Ch8 is T := It1.Typ; end; end if; + + if Etype (Nam) = Standard_Exception_Type then + Error_Msg_N + ("exception requires a subtype mark in renaming", Nam); + return; + end if; end if; -- The object renaming declaration may become Ghost if it renames a @@ -1354,7 +1362,7 @@ package body Sem_Ch8 is -- check. if Comes_From_Source (N) then - if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference) then + if Nkind (Nam) in N_Function_Call | N_Explicit_Dereference then Is_Object_Ref := Is_Object_Reference (Nam); else Is_Object_Ref := Is_Object_Reference (Original_Node (Nam)); @@ -1396,8 +1404,19 @@ package body Sem_Ch8 is and then Nkind (Original_Node (Nam)) /= N_Attribute_Reference then null; - else - Error_Msg_N ("expect object name in renaming", Nam); + + -- A named number can only be renamed without a subtype mark + + elsif Nkind (Nam) in N_Real_Literal | N_Integer_Literal + and then Present (Subtype_Mark (N)) + and then Present (Original_Entity (Nam)) + then + Error_Msg_N ("incompatible types in renaming", Nam); + + -- AI12-0383: Names that denote values can be renamed + + elsif Ada_Version < Ada_2020 then + Error_Msg_N ("value in renaming requires -gnat2020", Nam); end if; Set_Etype (Id, T2); @@ -2103,7 +2122,7 @@ package body Sem_Ch8 is -- Generate: -- return Subp_Id (Actuals); - if Ekind_In (Subp_Id, E_Function, E_Operator) then + if Ekind (Subp_Id) in E_Function | E_Operator then return Make_Simple_Return_Statement (Loc, Expression => @@ -2135,7 +2154,7 @@ package body Sem_Ch8 is Formal : Node_Id; begin - pragma Assert (Ekind_In (Subp_Id, E_Function, E_Operator)); + pragma Assert (Ekind (Subp_Id) in E_Function | E_Operator); -- Build the actual parameters of the call @@ -2502,7 +2521,7 @@ package body Sem_Ch8 is -- dispatching call to the wrapped function is known during proof. if GNATprove_Mode - and then Ekind_In (Ren_Id, E_Function, E_Operator) + and then Ekind (Ren_Id) in E_Function | E_Operator then New_Spec := Build_Spec (Ren_Id); Body_Decl := @@ -3160,6 +3179,22 @@ package body Sem_Ch8 is Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); end if; + -- AI12-0132: a renames-as-body freezes the expression of any + -- expression function that it renames. + + if Is_Entity_Name (Nam) + and then Is_Expression_Function (Entity (Nam)) + and then not Inside_A_Generic + then + Freeze_Expr_Types + (Def_Id => Entity (Nam), + Typ => Etype (Entity (Nam)), + Expr => + Expression + (Original_Node (Unit_Declaration_Node (Entity (Nam)))), + N => N); + end if; + -- Normal subprogram renaming (not renaming as body) else @@ -3360,7 +3395,7 @@ package body Sem_Ch8 is -- Guard against previous errors, and omit renamings of predefined -- operators. - elsif not Ekind_In (Old_S, E_Function, E_Procedure) then + elsif Ekind (Old_S) not in E_Function | E_Procedure then null; elsif Requires_Overriding (Old_S) @@ -4222,10 +4257,9 @@ package body Sem_Ch8 is elsif Present (Expressions (Nam)) then Error_Msg_N ("illegal expressions in attribute reference", Nam); - elsif - Nam_In (Aname, Name_Compose, Name_Exponent, Name_Leading_Part, - Name_Pos, Name_Round, Name_Scaling, - Name_Val) + elsif Aname in Name_Compose | Name_Exponent | Name_Leading_Part | + Name_Pos | Name_Round | Name_Scaling | + Name_Val then if Nkind (N) = N_Subprogram_Renaming_Declaration and then Present (Corresponding_Formal_Spec (N)) @@ -4489,8 +4523,8 @@ package body Sem_Ch8 is elsif Is_Concurrent_Type (Scope (E)) then P := Parent (N); while Present (P) - and then not Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) + and then Nkind (P) not in + N_Parameter_Specification | N_Component_Declaration loop P := Parent (P); end loop; @@ -4728,8 +4762,8 @@ package body Sem_Ch8 is Pop_Scope; while not (Is_List_Member (Decl)) - or else Nkind_In (Parent (Decl), N_Protected_Definition, - N_Task_Definition) + or else Nkind (Parent (Decl)) in N_Protected_Definition + | N_Task_Definition loop Decl := Parent (Decl); end loop; @@ -5508,7 +5542,7 @@ package body Sem_Ch8 is -- is Put or Put_Line, then add a special error message (since -- this is a very common error for beginners to make). - if Nam_In (Chars (N), Name_Put, Name_Put_Line) then + if Chars (N) in Name_Put | Name_Put_Line then Error_Msg_N -- CODEFIX ("\\possible missing `WITH Ada.Text_'I'O; " & "USE Ada.Text_'I'O`!", N); @@ -6093,9 +6127,9 @@ package body Sem_Ch8 is if Ada_Version >= Ada_2012 and then (Nkind (Parent (N)) in N_Subexpr - or else Nkind_In (Parent (N), N_Assignment_Statement, - N_Object_Declaration, - N_Parameter_Association)) + or else Nkind (Parent (N)) in N_Assignment_Statement + | N_Object_Declaration + | N_Parameter_Association) then Check_Implicit_Dereference (N, Etype (E)); end if; @@ -6182,13 +6216,13 @@ package body Sem_Ch8 is Par := Nod; while Present (Par) loop if Nkind (Par) = N_Pragma then - if Nam_In (Pragma_Name_Unmapped (Par), - Name_Abstract_State, - Name_Depends, - Name_Global, - Name_Initializes, - Name_Refined_Depends, - Name_Refined_Global) + if Pragma_Name_Unmapped (Par) + in Name_Abstract_State + | Name_Depends + | Name_Global + | Name_Initializes + | Name_Refined_Depends + | Name_Refined_Global then return True; @@ -6289,7 +6323,7 @@ package body Sem_Ch8 is -- The non-limited view may itself be incomplete, in which case -- get the full view if available. - elsif Ekind_In (Id, E_Incomplete_Type, E_Class_Wide_Type) + elsif Ekind (Id) in E_Incomplete_Type | E_Class_Wide_Type and then From_Limited_With (Id) and then Present (Non_Limited_View (Id)) and then Scope (Non_Limited_View (Id)) = P_Name @@ -6343,7 +6377,7 @@ package body Sem_Ch8 is end; if No (Id) - and then Ekind_In (P_Name, E_Procedure, E_Function) + and then Ekind (P_Name) in E_Procedure | E_Function and then Is_Generic_Instance (P_Name) then -- Expanded name denotes entity in (instance of) generic subprogram. @@ -6474,9 +6508,7 @@ package body Sem_Ch8 is exit when S = Standard_Standard; - if Ekind_In (S, E_Function, - E_Package, - E_Procedure) + if Ekind (S) in E_Function | E_Package | E_Procedure then P := Generic_Parent (Specification @@ -7483,7 +7515,7 @@ package body Sem_Ch8 is -- The subprogram may be a renaming (of an enclosing scope) as -- in the case of the name of the generic within an instantiation. - if Ekind_In (P_Name, E_Procedure, E_Function) + if Ekind (P_Name) in E_Procedure | E_Function and then Present (Alias (P_Name)) and then Is_Generic_Instance (Alias (P_Name)) then @@ -8180,11 +8212,13 @@ package body Sem_Ch8 is else Add_One_Interp (N, Predef_Op2, T); end if; - else if not Is_Binary_Op then Add_One_Interp (N, Predef_Op, T); - else + + -- Predef_Op2 may be empty in case of previous errors + + elsif Present (Predef_Op2) then Add_One_Interp (N, Predef_Op2, T); end if; end if; @@ -8442,7 +8476,7 @@ package body Sem_Ch8 is pragma Assert (No (Old_F)); - if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then + if Ekind (Old_S) in E_Function | E_Enumeration_Literal then Set_Etype (New_S, Etype (Old_S)); end if; end if; @@ -8643,7 +8677,7 @@ package body Sem_Ch8 is -- Use clauses in and of themselves do not count as a "use" of a -- package. - if Nkind_In (Parent (Id), N_Use_Package_Clause, N_Use_Type_Clause) then + if Nkind (Parent (Id)) in N_Use_Package_Clause | N_Use_Type_Clause then return; end if; @@ -8665,11 +8699,11 @@ package body Sem_Ch8 is -- Mark primitives elsif (Ekind (Id) in Overloadable_Kind - or else Ekind_In (Id, E_Generic_Function, - E_Generic_Procedure)) + or else Ekind (Id) in + E_Generic_Function | E_Generic_Procedure) and then (Is_Potentially_Use_Visible (Id) or else Is_Intrinsic_Subprogram (Id) - or else (Ekind_In (Id, E_Function, E_Procedure) + or else (Ekind (Id) in E_Function | E_Procedure and then Is_Generic_Actual_Subprogram (Id))) then Mark_Parameters (Id); @@ -8705,7 +8739,7 @@ package body Sem_Ch8 is -- Ignore fully qualified names as they do not count as a "use" of -- a package. - if Nkind_In (Id, N_Identifier, N_Operator_Symbol) + if Nkind (Id) in N_Identifier | N_Operator_Symbol or else (Present (Prefix (Id)) and then Scope (Entity (Id)) /= Entity (Prefix (Id))) then @@ -9461,9 +9495,14 @@ package body Sem_Ch8 is Set_Redundant_Use (Clause, True); + -- Do not check for redundant use if clause is generated, or in an + -- instance, or in a predefined unit to avoid misleading warnings + -- that may occur as part of a rtsfind load. + if not Comes_From_Source (Clause) or else In_Instance or else not Warn_On_Redundant_Constructs + or else Is_Predefined_Unit (Current_Sem_Unit) then return; end if; @@ -9596,10 +9635,12 @@ package body Sem_Ch8 is Private_Declarations (Parent (Decl)) then declare - Par : constant Entity_Id := Defining_Entity (Parent (Decl)); - Spec : constant Node_Id := - Specification (Unit (Cunit (Current_Sem_Unit))); + Par : constant Entity_Id := + Defining_Entity (Parent (Decl)); + Spec : constant Node_Id := + Specification (Unit (Cunit (Current_Sem_Unit))); Cur_List : constant List_Id := List_Containing (Cur_Use); + begin if Is_Compilation_Unit (Par) and then Par /= Cunit_Entity (Current_Sem_Unit) @@ -9641,7 +9682,7 @@ package body Sem_Ch8 is Error_Msg_Sloc := Sloc (Prev_Use); Error_Msg_NE -- CODEFIX - ("& is already use-visible through previous use_clause #??", + ("& is already use-visible through previous use_clause #?r?", Redundant, Pack_Name); end if; end Note_Redundant_Use; @@ -10232,7 +10273,7 @@ package body Sem_Ch8 is & "use_type_clause #??", Clause1, T); return; - elsif Nkind_In (Unit2, N_Package_Body, N_Subprogram_Body) + elsif Nkind (Unit2) in N_Package_Body | N_Subprogram_Body and then Nkind (Unit1) /= Nkind (Unit2) and then Nkind (Unit1) /= N_Subunit then diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 4fe3c9b..effc858 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -133,8 +133,8 @@ package body Sem_Ch9 is -- when Lock_Free_Given is True. begin - pragma Assert (Nkind_In (N, N_Protected_Type_Declaration, - N_Protected_Body)); + pragma Assert + (Nkind (N) in N_Protected_Type_Declaration | N_Protected_Body); -- The lock-free implementation is currently enabled through a debug -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the @@ -569,7 +569,7 @@ package body Sem_Ch9 is if Ekind (Id) = E_Component then Comp_Id := Id; - elsif Ekind_In (Id, E_Constant, E_Variable) + elsif Ekind (Id) in E_Constant | E_Variable and then Present (Prival_Link (Id)) then Comp_Id := Prival_Link (Id); @@ -1113,7 +1113,7 @@ package body Sem_Ch9 is Analyze_List (Pragmas_Before (N)); end if; - if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then + if Nkind (Parent (N)) in N_Selective_Accept | N_Timed_Entry_Call then Expr := Expression (Delay_Statement (N)); -- Defer full analysis until the statement is expanded, to insure @@ -1966,7 +1966,7 @@ package body Sem_Ch9 is Item_Id := First_Entity (Prot_Typ); while Present (Item_Id) loop - if Ekind_In (Item_Id, E_Function, E_Procedure) then + if Ekind (Item_Id) in E_Function | E_Procedure then Set_Convention (Item_Id, Convention_Protected); else Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id)); @@ -2317,7 +2317,7 @@ package body Sem_Ch9 is Enclosing := Scope_Stack.Table (J).Entity; exit when Is_Entry (Enclosing); - if not Ekind_In (Enclosing, E_Block, E_Loop) then + if Ekind (Enclosing) not in E_Block | E_Loop then Error_Msg_N ("requeue must appear within accept or entry body", N); return; end if; @@ -2550,7 +2550,7 @@ package body Sem_Ch9 is -- perform an unconditional goto so that any further -- references will not occur anyway. - if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then + if Ekind (Ent) in E_Out_Parameter | E_In_Out_Parameter then Set_Never_Set_In_Source (Ent, False); Set_Is_True_Constant (Ent, False); end if; @@ -3470,7 +3470,7 @@ package body Sem_Ch9 is begin pragma Assert - (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); + (Nkind (N) in N_Protected_Type_Declaration | N_Task_Type_Declaration); if Present (Interface_List (N)) then Set_Is_Tagged_Type (T); diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index d22e5d2..cb93fdb 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -623,8 +623,8 @@ package body Sem_Dim is -- Named symbol argument if No (Symbol_Expr) - or else not Nkind_In (Symbol_Expr, N_Character_Literal, - N_String_Literal) + or else Nkind (Symbol_Expr) not in + N_Character_Literal | N_String_Literal then Symbol_Expr := Empty; @@ -644,8 +644,8 @@ package body Sem_Dim is -- Verify symbol expression is a string or a character - if not Nkind_In (Symbol_Expr, N_Character_Literal, - N_String_Literal) + if Nkind (Symbol_Expr) not in + N_Character_Literal | N_String_Literal then Symbol_Expr := Empty; Error_Msg_N @@ -656,8 +656,8 @@ package body Sem_Dim is -- Special error if no Symbol choice but expression is string -- or character. - elsif Nkind_In (Expression (Assoc), N_Character_Literal, - N_String_Literal) + elsif Nkind (Expression (Assoc)) in + N_Character_Literal | N_String_Literal then Num_Choices := Num_Choices + 1; Error_Msg_N @@ -1039,8 +1039,8 @@ package body Sem_Dim is -- Check the second argument for each dimension aggregate is -- a string or a character. - if not Nkind_In (Unit_Symbol, N_String_Literal, - N_Character_Literal) + if Nkind (Unit_Symbol) not in + N_String_Literal | N_Character_Literal then Error_Msg_N ("expected unit symbol (string or character)", @@ -1072,8 +1072,8 @@ package body Sem_Dim is -- Check the third argument for each dimension aggregate is -- a string or a character. - if not Nkind_In (Dim_Symbol, N_String_Literal, - N_Character_Literal) + if Nkind (Dim_Symbol) not in + N_String_Literal | N_Character_Literal then Error_Msg_N ("expected dimension symbol (string or character)", @@ -1143,13 +1143,11 @@ package body Sem_Dim is return; elsif not Comes_From_Source (N) then - if Nkind_In (N, N_Explicit_Dereference, - N_Identifier, - N_Object_Declaration, - N_Subtype_Declaration) + if Nkind (N) not in N_Explicit_Dereference + | N_Identifier + | N_Object_Declaration + | N_Subtype_Declaration then - null; - else return; end if; end if; @@ -1441,9 +1439,8 @@ package body Sem_Dim is return; end if; - if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract) - or else N_Kind in N_Multiplying_Operator - or else N_Kind in N_Op_Compare + if N_Kind in N_Op_Add | N_Op_Expon | N_Op_Subtract + | N_Multiplying_Operator | N_Op_Compare then declare L : constant Node_Id := Left_Opnd (N); @@ -1459,7 +1456,7 @@ package body Sem_Dim is begin -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case - if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then + if N_Kind in N_Op_Add | N_Op_Mod | N_Op_Rem | N_Op_Subtract then -- Check both operands have same dimension @@ -1475,7 +1472,7 @@ package body Sem_Dim is -- N_Op_Multiply or N_Op_Divide case - elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then + elsif N_Kind in N_Op_Multiply | N_Op_Divide then -- Check at least one operand is not dimensionless @@ -1593,13 +1590,13 @@ package body Sem_Dim is -- literal is treated as if its dimension matches the type -- dimension. - elsif Nkind_In (Original_Node (L), N_Integer_Literal, - N_Real_Literal) + elsif Nkind (Original_Node (L)) in + N_Integer_Literal | N_Real_Literal then Dim_Warning_For_Numeric_Literal (L, Etype (R)); - elsif Nkind_In (Original_Node (R), N_Integer_Literal, - N_Real_Literal) + elsif Nkind (Original_Node (R)) in + N_Integer_Literal | N_Real_Literal then Dim_Warning_For_Numeric_Literal (R, Etype (L)); @@ -1875,8 +1872,8 @@ package body Sem_Dim is -- dimensionless to indicate the literal is treated as if its -- dimension matches the type dimension. - if Nkind_In (Original_Node (Expr), N_Real_Literal, - N_Integer_Literal) + if Nkind (Original_Node (Expr)) in + N_Real_Literal | N_Integer_Literal then Dim_Warning_For_Numeric_Literal (Expr, Etyp); @@ -2065,8 +2062,8 @@ package body Sem_Dim is if Present (Expr) and then Dims_Of_Typ /= Dimensions_Of (Expr) - and then Nkind_In (Original_Node (Expr), N_Real_Literal, - N_Integer_Literal) + and then Nkind (Original_Node (Expr)) in + N_Real_Literal | N_Integer_Literal then Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ)); end if; @@ -2105,7 +2102,7 @@ package body Sem_Dim is Check_Error_Detected; return; - elsif Ekind_In (Id, E_Constant, E_Named_Real) + elsif Ekind (Id) in E_Constant | E_Named_Real and then Exists (Dimensions_Of (Id)) then Set_Dimensions (N, Dimensions_Of (Id)); @@ -2242,8 +2239,8 @@ package body Sem_Dim is -- not dimensionless to indicate the literal is treated as if -- its dimension matches the type dimension. - if Nkind_In (Original_Node (Expr), N_Real_Literal, - N_Integer_Literal) + if Nkind (Original_Node (Expr)) in + N_Real_Literal | N_Integer_Literal then Dim_Warning_For_Numeric_Literal (Expr, Etyp); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 6e74098..67a8cdf 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -293,7 +293,7 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - if Ekind_In (Subp, E_Function, E_Generic_Function) then + if Ekind (Subp) in E_Function | E_Generic_Function then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then @@ -621,7 +621,7 @@ package body Sem_Disp is Par := Parent (Par); end if; - if Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) + if Nkind (Par) in N_Function_Call | N_Procedure_Call_Statement and then Is_Entity_Name (Name (Par)) then declare @@ -684,7 +684,7 @@ package body Sem_Disp is -- For equality operators, one of the operands must be -- statically or dynamically tagged. - elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then + elsif Nkind (Par) in N_Op_Eq | N_Op_Ne then if N = Right_Opnd (Par) and then Is_Tag_Indeterminate (Left_Opnd (Par)) then @@ -993,7 +993,7 @@ package body Sem_Disp is -- Start of processing for Check_Dispatching_Operation begin - if not Ekind_In (Subp, E_Function, E_Procedure) then + if Ekind (Subp) not in E_Function | E_Procedure then return; -- The Default_Initial_Condition procedure is not a primitive subprogram @@ -1409,7 +1409,7 @@ package body Sem_Disp is -- visible operation that may be declared in a partial view when -- the full view is controlled. - if Nam_In (Chars (Subp), Name_Initialize, Name_Adjust, Name_Finalize) + if Chars (Subp) in Name_Initialize | Name_Adjust | Name_Finalize and then Is_Controlled (Tagged_Type) and then not Is_Visibly_Controlled (Tagged_Type) and then not Is_Inherited_Public_Operation (Ovr_Subp) @@ -1569,10 +1569,10 @@ package body Sem_Disp is Set_DT_Position_Value (Subp, No_Uint); elsif Has_Controlled_Component (Tagged_Type) - and then Nam_In (Chars (Subp), Name_Initialize, - Name_Adjust, - Name_Finalize, - Name_Finalize_Address) + and then Chars (Subp) in Name_Initialize + | Name_Adjust + | Name_Finalize + | Name_Finalize_Address then declare F_Node : constant Node_Id := Freeze_Node (Tagged_Type); @@ -2010,7 +2010,7 @@ package body Sem_Disp is Ctrl_Type : Entity_Id; begin - if Ekind_In (Subp, E_Function, E_Procedure) + if Ekind (Subp) in E_Function | E_Procedure and then Present (DTC_Entity (Subp)) then return Scope (DTC_Entity (Subp)); diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 19f6bb7..4ee6e8b 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -746,13 +746,12 @@ package body Sem_Dist is -- we are generating code. if Comes_From_Source (P) + and then Expander_Active and then Is_Record_Type (ET) - and then (Is_Remote_Call_Interface (ET) - or else Is_Remote_Types (ET)) + and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) and then Present (Corresponding_Remote_Type (ET)) - and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, - N_Indexed_Component) - and then Expander_Active + and then Nkind (Parent (Parent (P))) in + N_Procedure_Call_Statement | N_Indexed_Component then RAS_E_Dereference (P); return True; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index e17e927..78108e9 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2609,7 +2609,7 @@ package body Sem_Elab is Par := Parent (Call); while Present (Par) loop - if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then + if Nkind (Par) in N_Package_Body | N_Package_Declaration then return Defining_Entity (Par); elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then @@ -2958,11 +2958,10 @@ package body Sem_Elab is -- task objects found in the declarations. else - pragma Assert (Nkind_In (Context, N_Block_Statement, - N_Entry_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body)); + pragma Assert + (Nkind (Context) in + N_Block_Statement | N_Entry_Body | N_Protected_Body | + N_Subprogram_Body | N_Task_Body); Traverse_List (List => Declarations (Context), @@ -2985,10 +2984,9 @@ package body Sem_Elab is -- When the name denotes an array or record component, find the whole -- object. - while Nkind_In (Nam, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) + while Nkind (Nam) in + N_Explicit_Dereference | N_Indexed_Component | + N_Selected_Component | N_Slice loop Nam := Prefix (Nam); end loop; @@ -3298,8 +3296,8 @@ package body Sem_Elab is elsif (Debug_Flag_Underscore_A or else Restriction_Active (No_Entry_Calls_In_Elaboration_Code)) - and then Nkind_In (Original_Node (Scen), N_Accept_Statement, - N_Selective_Accept) + and then Nkind (Original_Node (Scen)) in + N_Accept_Statement | N_Selective_Accept then return Abandon; @@ -3333,18 +3331,18 @@ package body Sem_Elab is -- until expansion transforms the node and relocates the contents. -- Examine these lists in case expansion is disabled. - elsif Nkind_In (Scen, N_And_Then, N_Or_Else) then + elsif Nkind (Scen) in N_And_Then | N_Or_Else then Traverse_List (Actions (Scen)); - elsif Nkind_In (Scen, N_Elsif_Part, N_Iteration_Scheme) then + elsif Nkind (Scen) in N_Elsif_Part | N_Iteration_Scheme then Traverse_List (Condition_Actions (Scen)); elsif Nkind (Scen) = N_If_Expression then Traverse_List (Then_Actions (Scen)); Traverse_List (Else_Actions (Scen)); - elsif Nkind_In (Scen, N_Component_Association, - N_Iterated_Component_Association) + elsif Nkind (Scen) in + N_Component_Association | N_Iterated_Component_Association then Traverse_List (Loop_Actions (Scen)); @@ -3515,8 +3513,7 @@ package body Sem_Elab is -- contexts because nested calls has not been relocated to their -- final context. - if Nkind_In (Par, N_Aspect_Specification, - N_Generic_Association) + if Nkind (Par) in N_Aspect_Specification | N_Generic_Association then return True; @@ -3544,9 +3541,9 @@ package body Sem_Elab is -- To qualify, the node must appear immediately within a source call -- which invokes a source target. - if Nkind_In (Outer_Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (Outer_Call) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement and then Comes_From_Source (Outer_Call) then Outer_Nam := Call_Name (Outer_Call); @@ -3576,9 +3573,9 @@ package body Sem_Elab is return Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration and then not Comes_From_Source (Subp_Decl) - and then Nkind_In (Context, N_Function_Specification, - N_Package_Specification, - N_Procedure_Specification) + and then Nkind (Context) in N_Function_Specification + | N_Package_Specification + | N_Procedure_Specification and then Present (Generic_Parent (Context)); end Is_Generic_Formal_Subp; @@ -3612,10 +3609,10 @@ package body Sem_Elab is -- Nothing to do when the input does not denote a call or a requeue - elsif not Nkind_In (N, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement, - N_Requeue_Statement) + elsif Nkind (N) not in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement + | N_Requeue_Statement then return; @@ -3624,7 +3621,7 @@ package body Sem_Elab is -- elaboration) is in effect. elsif Debug_Flag_Underscore_E - and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) + and then Nkind (N) in N_Entry_Call_Statement | N_Requeue_Statement then return; @@ -3687,7 +3684,7 @@ package body Sem_Elab is -- Static expression functions require no ABE processing - elsif Is_Static_Expression_Function (Subp_Id) then + elsif Is_Static_Function (Subp_Id) then return; -- Source calls to source targets are always considered because they @@ -3740,8 +3737,9 @@ package body Sem_Elab is (Marker, Find_Enclosing_Level (N) = Declaration_Level); Set_Is_Dispatching_Call - (Marker, Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) - and then Present (Controlling_Argument (N))); + (Marker, + Nkind (N) in N_Function_Call | N_Procedure_Call_Statement + and then Present (Controlling_Argument (N))); Set_Is_Elaboration_Checks_OK_Node (Marker, Is_Elaboration_Checks_OK_Node (N)); @@ -4537,8 +4535,8 @@ package body Sem_Elab is -- statement due to expansion activities. if Nkind (Comp_Unit) = N_Null_Statement - and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, - N_Task_Body) + and then Nkind (Original_Node (Comp_Unit)) in + N_Protected_Body | N_Task_Body then Comp_Unit := Parent (Comp_Unit); pragma Assert (Nkind (Comp_Unit) = N_Subunit); @@ -4554,9 +4552,8 @@ package body Sem_Elab is -- the instantiated subprogram. if Nkind (Comp_Unit) = N_Package_Specification - and then Nkind_In (Original_Node (Parent (Comp_Unit)), - N_Function_Instantiation, - N_Procedure_Instantiation) + and then Nkind (Original_Node (Parent (Comp_Unit))) in + N_Function_Instantiation | N_Procedure_Instantiation then Comp_Unit := Parent (Parent (Comp_Unit)); @@ -7031,7 +7028,7 @@ package body Sem_Elab is -- Enter encapsulators by inspecting their declarations and/or -- statements. - if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then + if Nkind (Curr) in N_Block_Statement | N_Package_Body then Enter_Handled_Body (Curr); elsif Nkind (Curr) = N_Package_Declaration then @@ -7062,7 +7059,7 @@ package body Sem_Elab is -- amount of work, but has the beneficial effect of computing -- the early call regions of all preceding bodies. - elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then + elsif Nkind (Curr) in N_Entry_Body | N_Subprogram_Body then Start := Find_Early_Call_Region (Body_Decl => Curr, @@ -7098,9 +7095,9 @@ package body Sem_Elab is -- visible declarations -> upper level -- visible declarations -> terminate - if Nkind_In (Context, N_Package_Specification, - N_Protected_Definition, - N_Task_Definition) + if Nkind (Context) in N_Package_Specification + | N_Protected_Definition + | N_Task_Definition then Transition_Spec_Declarations (Context, Curr); @@ -7120,12 +7117,12 @@ package body Sem_Elab is -- declarations -> corresponding package spec (Elab_Body) -- declarations -> terminate - elsif Nkind_In (Context, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Nkind (Context) in N_Block_Statement + | N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body then Transition_Body_Declarations (Context, Curr); @@ -7430,12 +7427,14 @@ package body Sem_Elab is -- The search must come from the statements of certain bodies or -- statements. - pragma Assert (Nkind_In (Bod, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body)); + pragma Assert + (Nkind (Bod) in + N_Block_Statement | + N_Entry_Body | + N_Package_Body | + N_Protected_Body | + N_Subprogram_Body | + N_Task_Body); -- The search must come from the statements of the handled -- sequence. @@ -7831,7 +7830,7 @@ package body Sem_Elab is begin -- Nothing to do if the pragma is not related to elaboration - if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then + if Prag_Nam not in Name_Elaborate | Name_Elaborate_All then return; -- Nothing to do when the pragma is illegal @@ -8006,7 +8005,7 @@ package body Sem_Elab is -- body -> spec if Present (Unit_Id) - and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body) + and then Nkind (Unit_Id) in N_Package_Body | N_Subprogram_Body then Find_Elaboration_Context (Parent (Unit_Id)); @@ -8026,10 +8025,10 @@ package body Sem_Elab is -- parent spec -> grandparent spec and so on if Present (Unit_Id) - and then Nkind_In (Unit_Id, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Declaration) + and then Nkind (Unit_Id) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Subprogram_Declaration then Find_Elaboration_Context (Parent (Unit_Id)); @@ -8110,7 +8109,7 @@ package body Sem_Elab is Prag_Nam : Name_Id; In_State : Processing_In_State) is - pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); + pragma Assert (Prag_Nam in Name_Elaborate | Name_Elaborate_All); begin -- Nothing to do when the need for prior elaboration came from a @@ -8581,7 +8580,7 @@ package body Sem_Elab is Req_Nam : Name_Id; In_State : Processing_In_State) is - pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); + pragma Assert (Req_Nam in Name_Elaborate | Name_Elaborate_All); Main_Id : constant Entity_Id := Main_Unit_Entity; Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); @@ -8777,8 +8776,7 @@ package body Sem_Elab is -- requirement. if Present (Unit_Prag) - and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All, - Req_Nam) + and then Pragma_Name (Unit_Prag) in Name_Elaborate_All | Req_Nam then Req_Met := True; @@ -8907,10 +8905,10 @@ package body Sem_Elab is Par := N; while Present (Par) loop - if Nkind_In (Par, N_Package_Body, - N_Package_Declaration, - N_Subprogram_Body, - N_Subprogram_Declaration) + if Nkind (Par) in N_Package_Body + | N_Package_Declaration + | N_Subprogram_Body + | N_Subprogram_Declaration and then Is_Generic_Instance (Unique_Defining_Entity (Par)) then return Par; @@ -8983,10 +8981,10 @@ package body Sem_Elab is -- but are later relocated in a different context retain their original -- declaration level. - if Nkind_In (N, N_Call_Marker, - N_Function_Instantiation, - N_Package_Instantiation, - N_Procedure_Instantiation) + if Nkind (N) in N_Call_Marker + | N_Function_Instantiation + | N_Package_Instantiation + | N_Procedure_Instantiation and then Is_Declaration_Level_Node (N) then return Declaration_Level; @@ -9007,7 +9005,7 @@ package body Sem_Elab is -- they are always elaborated when the enclosing context is invoked -- or elaborated. - elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then + elsif Nkind (Curr) in N_Package_Body | N_Package_Declaration then null; -- The current construct is a block statement @@ -9039,9 +9037,8 @@ package body Sem_Elab is -- The current construct is a declaration-level encapsulator - elsif Nkind_In (Curr, N_Entry_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Nkind (Curr) in + N_Entry_Body | N_Subprogram_Body | N_Task_Body then -- If the traversal came from the handled sequence of statments, -- then the node cannot possibly appear at any level. This is @@ -9129,8 +9126,8 @@ package body Sem_Elab is -- that of the "related instance". elsif Nkind (N) = N_Package_Declaration - and then Nkind_In (Orig_N, N_Function_Instantiation, - N_Procedure_Instantiation) + and then Nkind (Orig_N) in + N_Function_Instantiation | N_Procedure_Instantiation and then Nkind (Context) = N_Compilation_Unit then return Related_Instance (Defining_Entity (N)); @@ -9141,8 +9138,8 @@ package body Sem_Elab is elsif Nkind (N) = N_Subunit and then Nkind (Proper_Body (N)) = N_Null_Statement - and then Nkind_In (Original_Node (Proper_Body (N)), N_Protected_Body, - N_Task_Body) + and then Nkind (Original_Node (Proper_Body (N))) in + N_Protected_Body | N_Task_Body then return Defining_Entity (Original_Node (Proper_Body (N))); @@ -9168,7 +9165,7 @@ package body Sem_Elab is -- Handle various combinations of concurrent and private types loop - if Ekind_In (Typ, E_Protected_Type, E_Task_Type) + if Ekind (Typ) in E_Protected_Type | E_Task_Type and then Present (Anonymous_Object (Typ)) then Typ := Anonymous_Object (Typ); @@ -10911,13 +10908,10 @@ package body Sem_Elab is elsif Is_Task_Type (Id) then Rec := Create_Task_Rep (Id); - elsif Ekind_In (Id, E_Constant, E_Variable) then + elsif Ekind (Id) in E_Constant | E_Variable then Rec := Create_Variable_Rep (Id); - elsif Ekind_In (Id, E_Entry, - E_Function, - E_Operator, - E_Procedure) + elsif Ekind (Id) in E_Entry | E_Function | E_Operator | E_Procedure then Rec := Create_Subprogram_Rep (Id); @@ -12094,14 +12088,13 @@ package body Sem_Elab is -- The main unit is a body - if Ekind_In (Main_Unit_Id, E_Package_Body, - E_Subprogram_Body) + if Ekind (Main_Unit_Id) in E_Package_Body | E_Subprogram_Body then return In_Body; -- The main unit is a stand-alone subprogram body - elsif Ekind_In (Main_Unit_Id, E_Function, E_Procedure) + elsif Ekind (Main_Unit_Id) in E_Function | E_Procedure and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) = N_Subprogram_Body then @@ -12116,8 +12109,7 @@ package body Sem_Elab is -- Otherwise the node is in the complementary unit of the main -- unit. The main unit is a body, the node is in the spec. - elsif Ekind_In (Main_Unit_Id, E_Package_Body, - E_Subprogram_Body) + elsif Ekind (Main_Unit_Id) in E_Package_Body | E_Subprogram_Body then return In_Spec; @@ -12342,8 +12334,8 @@ package body Sem_Elab is -- Protected type - elsif Nkind_In (Decl, N_Protected_Type_Declaration, - N_Single_Protected_Declaration) + elsif Nkind (Decl) in N_Protected_Type_Declaration + | N_Single_Protected_Declaration then Process_Protected_Type_Declaration (Prot_Decl => Decl, @@ -12351,8 +12343,8 @@ package body Sem_Elab is -- Subprogram or entry - elsif Nkind_In (Decl, N_Entry_Declaration, - N_Subprogram_Declaration) + elsif Nkind (Decl) in N_Entry_Declaration + | N_Subprogram_Declaration then Process_Subprogram_Declaration (Subp_Decl => Decl, @@ -12376,8 +12368,8 @@ package body Sem_Elab is -- Task type - elsif Nkind_In (Decl, N_Single_Task_Declaration, - N_Task_Type_Declaration) + elsif Nkind (Decl) in N_Single_Task_Declaration + | N_Task_Type_Declaration then Process_Task_Type_Declaration (Task_Decl => Decl, @@ -12497,7 +12489,7 @@ package body Sem_Elab is -- Nothing to do for an abstract subprogram because it has no body to -- examine. - elsif Ekind_In (Subp_Id, E_Function, E_Procedure) + elsif Ekind (Subp_Id) in E_Function | E_Procedure and then Is_Abstract_Subprogram (Subp_Id) then return; @@ -12513,7 +12505,7 @@ package body Sem_Elab is -- DFS traversal into its barrier function and body. if In_Extended_Main_Code_Unit (Subp_Id) then - if Ekind_In (Subp_Id, E_Entry, E_Entry_Family, E_Procedure) then + if Ekind (Subp_Id) in E_Entry | E_Entry_Family | E_Procedure then Traverse_Invocation_Body (N => Barrier_Body_Declaration (Subp_Rep), In_State => In_State); @@ -12893,8 +12885,8 @@ package body Sem_Elab is -- Process the entries of the task type because they represent valid -- entry points into the task body. - if Nkind_In (Task_Decl, N_Single_Task_Declaration, - N_Task_Type_Declaration) + if Nkind (Task_Decl) in N_Single_Task_Declaration + | N_Task_Type_Declaration then Task_Def := Task_Definition (Task_Decl); @@ -13192,10 +13184,8 @@ package body Sem_Elab is -- Entry, operator, or subprogram call. This case must come last -- because most invocations above are variations of this case. - elsif Ekind_In (Targ_Id, E_Entry, - E_Function, - E_Operator, - E_Procedure) + elsif Ekind (Targ_Id) in + E_Entry | E_Function | E_Operator | E_Procedure then Extra := Empty; Kind := Call; @@ -14460,9 +14450,7 @@ package body Sem_Elab is begin -- An abstract subprogram does not have a body - if Ekind_In (Subp_Id, E_Function, - E_Operator, - E_Procedure) + if Ekind (Subp_Id) in E_Function | E_Operator | E_Procedure and then Is_Abstract_Subprogram (Subp_Id) then return True; @@ -14510,9 +14498,8 @@ package body Sem_Elab is Formal_Id : Entity_Id; begin - pragma Assert (Nam_In (Subp_Nam, Name_Adjust, - Name_Finalize, - Name_Initialize)); + pragma Assert + (Subp_Nam in Name_Adjust | Name_Finalize | Name_Initialize); -- To qualify, the subprogram must denote a source procedure with -- name Adjust, Finalize, or Initialize where the sole formal is @@ -14700,7 +14687,7 @@ package body Sem_Elab is -- protected type. return - Ekind_In (Id, E_Function, E_Procedure) + Ekind (Id) in E_Function | E_Procedure and then Is_Protected_Type (Non_Private_View (Scope (Id))); end Is_Protected_Subp; @@ -14714,7 +14701,7 @@ package body Sem_Elab is -- Protected_Subprogram set. return - Ekind_In (Id, E_Function, E_Procedure) + Ekind (Id) in E_Function | E_Procedure and then Present (Protected_Subprogram (Id)); end Is_Protected_Body_Subp; @@ -14766,7 +14753,7 @@ package body Sem_Elab is -- is hidden within an anonymous package, and is a generic instance. return - Ekind_In (Id, E_Function, E_Procedure) + Ekind (Id) in E_Function | E_Procedure and then Is_Hidden (Id) and then Is_Generic_Instance (Id); end Is_Subprogram_Inst; @@ -14835,7 +14822,7 @@ package body Sem_Elab is -- The attribute name must be one of the 'Access forms. Note that -- 'Unchecked_Access cannot apply to a subprogram. - and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); + and then Nam in Name_Access | Name_Unrestricted_Access; end Is_Suitable_Access_Taken; ---------------------- @@ -15869,10 +15856,10 @@ package body Sem_Elab is -- Bodies - if Nkind_In (N, N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + if Nkind (N) in N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body then Spec_Id := Corresponding_Spec (N); @@ -15892,13 +15879,13 @@ package body Sem_Elab is -- Declarations - elsif Nkind_In (N, N_Entry_Declaration, - N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Protected_Type_Declaration, - N_Subprogram_Declaration, - N_Task_Type_Declaration) + elsif Nkind (N) in N_Entry_Declaration + | N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Protected_Type_Declaration + | N_Subprogram_Declaration + | N_Task_Type_Declaration then Spec_Decl := N; @@ -15972,12 +15959,12 @@ package body Sem_Elab is begin return - Nkind_In (Decl, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Protected_Type_Declaration, - N_Subprogram_Declaration, - N_Task_Type_Declaration) + Nkind (Decl) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Protected_Type_Declaration + | N_Subprogram_Declaration + | N_Task_Type_Declaration and then Present (Corresponding_Body (Decl)) and then Nkind (Parent (Unit_Declaration_Node (Corresponding_Body (Decl)))) = N_Subunit; @@ -16846,8 +16833,8 @@ package body Sem_Elab is if Nkind (Decl) = N_Subprogram_Body then Body_Acts_As_Spec := True; - elsif Nkind_In (Decl, N_Subprogram_Declaration, - N_Subprogram_Body_Stub) + elsif Nkind (Decl) in + N_Subprogram_Declaration | N_Subprogram_Body_Stub or else Inst_Case then Body_Acts_As_Spec := False; @@ -17523,8 +17510,7 @@ package body Sem_Elab is P := Parent (N); while Present (P) loop - if Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) + if Nkind (P) in N_Parameter_Specification | N_Component_Declaration then return; @@ -17619,8 +17605,8 @@ package body Sem_Elab is -- Filter out case of default expressions, where we do not -- do the check at this stage. - if Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) + if Nkind (P) in + N_Parameter_Specification | N_Component_Declaration then return; end if; @@ -17631,10 +17617,10 @@ package body Sem_Elab is if Nkind (P) = N_Protected_Body then return; - elsif Nkind_In (P, N_Subprogram_Body, - N_Task_Body, - N_Block_Statement, - N_Entry_Body) + elsif Nkind (P) in N_Subprogram_Body + | N_Task_Body + | N_Block_Statement + | N_Entry_Body then if L = Declarations (P) then exit; @@ -17857,10 +17843,7 @@ package body Sem_Elab is -- then there is nothing to do (we do not know what is being assigned), -- but otherwise this is an assignment to the prefix. - if Nkind_In (N, N_Indexed_Component, - N_Selected_Component, - N_Slice) - then + if Nkind (N) in N_Indexed_Component | N_Selected_Component | N_Slice then if not Is_Access_Type (Etype (Prefix (N))) then Check_Elab_Assign (Prefix (N)); end if; @@ -18285,9 +18268,9 @@ package body Sem_Elab is -- If not function or procedure call, instantiation, or 'Access, then -- ignore call (this happens in some error cases and rewriting cases). - elsif not Nkind_In (N, N_Attribute_Reference, - N_Function_Call, - N_Procedure_Call_Statement) + elsif Nkind (N) not in N_Attribute_Reference + | N_Function_Call + | N_Procedure_Call_Statement and then not Inst_Case then return; @@ -18387,8 +18370,8 @@ package body Sem_Elab is -- code, do not trace past an accept statement, because the rendez- -- vous will happen after elaboration. - if Nkind_In (Original_Node (N), N_Accept_Statement, - N_Selective_Accept) + if Nkind (Original_Node (N)) in + N_Accept_Statement | N_Selective_Accept and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then return Abandon; @@ -18421,8 +18404,8 @@ package body Sem_Elab is elsif not Debug_Flag_Dot_UU and then Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Access, - Name_Unrestricted_Access) + and then + Attribute_Name (N) in Name_Access | Name_Unrestricted_Access and then Is_Entity_Name (Prefix (N)) and then Is_Subprogram (Entity (Prefix (N))) then @@ -18503,7 +18486,7 @@ package body Sem_Elab is Sbody := Unit_Declaration_Node (E); - if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then + if Nkind (Sbody) not in N_Subprogram_Body | N_Package_Body then Ebody := Corresponding_Body (Sbody); if No (Ebody) then @@ -18597,7 +18580,7 @@ package body Sem_Elab is -- Check we have an If statement or a null statement (happens -- when the If has been expanded to be True). - exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); + exit when Nkind (P) not in N_If_Statement | N_Null_Statement; -- Our special case will be indicated either by the pragma -- coming from an aspect ... @@ -18758,9 +18741,9 @@ package body Sem_Elab is -- A rather specific check. For Finalize/Adjust/Initialize, if -- the type has Warnings_Off set, suppress the warning. - if Nam_In (Chars (E), Name_Adjust, - Name_Finalize, - Name_Initialize) + if Chars (E) in Name_Adjust + | Name_Finalize + | Name_Initialize and then Present (First_Formal (E)) then declare @@ -19378,7 +19361,7 @@ package body Sem_Elab is function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is begin - return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + return Nkind (N) in N_Function_Call | N_Procedure_Call_Statement -- Always return False if debug flag -gnatd.G is set @@ -19545,7 +19528,7 @@ package body Sem_Elab is S1 := Scop1; while S1 /= Standard_Standard and then not Is_Compilation_Unit (S1) - and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block) + and then Ekind (S1) in E_Package | E_Protected_Type | E_Block loop S1 := Scope (S1); end loop; @@ -19555,7 +19538,7 @@ package body Sem_Elab is S2 := Scop2; while S2 /= Standard_Standard and then not Is_Compilation_Unit (S2) - and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block) + and then Ekind (S2) in E_Package | E_Protected_Type | E_Block loop S2 := Scope (S2); end loop; @@ -19680,7 +19663,7 @@ package body Sem_Elab is -- Check for case of body entity -- Why is the check for E_Void needed??? - if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then + if Ekind (E) in E_Void | E_Subprogram_Body | E_Package_Body then Decl := E; loop diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index 1ecb1bd..d693a8d 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -428,7 +428,7 @@ package body Sem_Elim is -- Check for case of subprogram - elsif Ekind_In (E, E_Function, E_Procedure) then + elsif Ekind (E) in E_Function | E_Procedure then -- If Source_Location present, then see if it matches diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 57dbaba..8c13abc 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -45,6 +45,7 @@ with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Elab; use Sem_Elab; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; @@ -171,6 +172,9 @@ package body Sem_Eval is -- discrete, real, or string type and must be a compile-time-known value -- (it is an error to make the call if these conditions are not met). + procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id); + -- Evaluate a call N to an intrinsic subprogram E. + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; -- Check whether an arithmetic operation with universal operands which is a -- rewritten function call with an explicit scope indication is ambiguous: @@ -179,6 +183,22 @@ package body Sem_Eval is -- (e.g. in the expression of a type conversion). If ambiguous, emit an -- error and return Empty, else return the result type of the operator. + procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id); + -- Rewrite N as a constant dummy value in the relevant type if possible. + + procedure Fold_Shift + (N : Node_Id; + Left : Node_Id; + Right : Node_Id; + Op : Node_Kind; + Static : Boolean := False; + Check_Elab : Boolean := False); + -- Rewrite N as the result of evaluating Left <shift op> Right if possible. + -- Op represents the shift operation. + -- Static indicates whether the resulting node should be marked static. + -- Check_Elab indicates whether checks for elaboration calls should be + -- inserted when relevant. + function From_Bits (B : Bits; T : Entity_Id) return Uint; -- Converts a bit string of length B'Length to a Uint value to be used for -- a target of type T, which is a modular type. This procedure includes the @@ -606,8 +626,8 @@ package body Sem_Eval is -- Determine if the out-of-range violation constitutes a warning -- or an error based on context, according to RM 4.9 (34/3). - elsif Nkind_In (Original_Node (N), N_Type_Conversion, - N_Qualified_Expression) + elsif Nkind (Original_Node (N)) in + N_Type_Conversion | N_Qualified_Expression and then Comes_From_Source (Original_Node (N)) then Apply_Compile_Time_Constraint_Error @@ -938,7 +958,7 @@ package body Sem_Eval is -- Fixup only required for First/Last attribute reference if Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_First, Name_Last) + and then Attribute_Name (N) in Name_First | Name_Last then Xtyp := Etype (Prefix (N)); @@ -1091,8 +1111,8 @@ package body Sem_Eval is -- Values are the same if they refer to the same entity and the -- entity is nonvolatile. - elsif Nkind_In (Lf, N_Identifier, N_Expanded_Name) - and then Nkind_In (Rf, N_Identifier, N_Expanded_Name) + elsif Nkind (Lf) in N_Identifier | N_Expanded_Name + and then Nkind (Rf) in N_Identifier | N_Expanded_Name and then Entity (Lf) = Entity (Rf) -- If the entity is a discriminant, the two expressions may be @@ -1134,9 +1154,9 @@ package body Sem_Eval is elsif Nkind (Lf) = N_Attribute_Reference and then Attribute_Name (Lf) = Attribute_Name (Rf) - and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last) - and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name) - and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name) + and then Attribute_Name (Lf) in Name_First | Name_Last + and then Nkind (Prefix (Lf)) in N_Identifier | N_Expanded_Name + and then Nkind (Prefix (Rf)) in N_Identifier | N_Expanded_Name and then Entity (Prefix (Lf)) = Entity (Prefix (Rf)) and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf)) then @@ -1829,11 +1849,8 @@ package body Sem_Eval is -- Other literals and NULL are known at compile time - elsif - Nkind_In (K, N_Character_Literal, - N_Real_Literal, - N_String_Literal, - N_Null) + elsif K in + N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null then return True; end if; @@ -2217,9 +2234,8 @@ package body Sem_Eval is -- Only the latter case is handled here, predefined operators are -- constant-folded elsewhere. - -- If the function is itself inherited (see 7423-001) the literal of - -- the parent type must be explicitly converted to the return type - -- of the function. + -- If the function is itself inherited the literal of the parent type must + -- be explicitly converted to the return type of the function. procedure Eval_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -2246,37 +2262,22 @@ package body Sem_Eval is Resolve (N, Typ); end if; + elsif Nkind (N) = N_Function_Call + and then Is_Entity_Name (Name (N)) + and then Is_Intrinsic_Subprogram (Entity (Name (N))) + then + Eval_Intrinsic_Call (N, Entity (Name (N))); + -- Ada 202x (AI12-0075): If checking for potentially static expressions - -- is enabled and we have a call to a static expression function, - -- substitute a static value for the call, to allow folding the - -- expression. This supports checking the requirement of RM 6.8(5.3/5) - -- in Analyze_Expression_Function. + -- is enabled and we have a call to a static function, substitute a + -- static value for the call, to allow folding the expression. This + -- supports checking the requirement of RM 6.8(5.3/5) in + -- Analyze_Expression_Function. elsif Checking_Potentially_Static_Expression - and then Is_Static_Expression_Function_Call (N) + and then Is_Static_Function_Call (N) then - if Is_Integer_Type (Typ) then - Fold_Uint (N, Uint_1, Static => True); - return; - - elsif Is_Real_Type (Typ) then - Fold_Ureal (N, Ureal_1, Static => True); - return; - - elsif Is_Enumeration_Type (Typ) then - Fold_Uint - (N, - Expr_Value (Type_Low_Bound (Base_Type (Typ))), - Static => True); - return; - - elsif Is_String_Type (Typ) then - Fold_Str - (N, - Strval (Make_String_Literal (Sloc (N), "")), - Static => True); - return; - end if; + Fold_Dummy (N, Typ); end if; end Eval_Call; @@ -2566,30 +2567,9 @@ package body Sem_Eval is elsif Ekind (Def_Id) = E_In_Parameter and then Checking_Potentially_Static_Expression - and then Is_Static_Expression_Function (Scope (Def_Id)) + and then Is_Static_Function (Scope (Def_Id)) then - if Is_Integer_Type (Etype (Def_Id)) then - Fold_Uint (N, Uint_1, Static => True); - return; - - elsif Is_Real_Type (Etype (Def_Id)) then - Fold_Ureal (N, Ureal_1, Static => True); - return; - - elsif Is_Enumeration_Type (Etype (Def_Id)) then - Fold_Uint - (N, - Expr_Value (Type_Low_Bound (Base_Type (Etype (Def_Id)))), - Static => True); - return; - - elsif Is_String_Type (Etype (Def_Id)) then - Fold_Str - (N, - Strval (Make_String_Literal (Sloc (N), "")), - Static => True); - return; - end if; + Fold_Dummy (N, Etype (Def_Id)); end if; -- Fall through if the name is not static @@ -2847,11 +2827,11 @@ package body Sem_Eval is -- so we can safely ignore these cases. return - Nkind_In (Context, N_Attribute_Definition_Clause, - N_Attribute_Reference, - N_Modular_Type_Definition, - N_Number_Declaration, - N_Signed_Integer_Type_Definition); + Nkind (Context) in N_Attribute_Definition_Clause + | N_Attribute_Reference + | N_Modular_Type_Definition + | N_Number_Declaration + | N_Signed_Integer_Type_Definition; end In_Any_Integer_Context; -- Local variables @@ -2874,10 +2854,10 @@ package body Sem_Eval is -- Check_Non_Static_Context on an expanded literal may lead to spurious -- and misleading warnings. - if (Nkind_In (Par, N_Case_Expression_Alternative, N_If_Expression) + if (Nkind (Par) in N_Case_Expression_Alternative | N_If_Expression or else Nkind (Par) not in N_Subexpr) - and then (not Nkind_In (Par, N_Case_Expression_Alternative, - N_If_Expression) + and then (Nkind (Par) not in N_Case_Expression_Alternative + | N_If_Expression or else Comes_From_Source (N)) and then not In_Any_Integer_Context (Par) then @@ -2893,6 +2873,80 @@ package body Sem_Eval is end if; end Eval_Integer_Literal; + ------------------------- + -- Eval_Intrinsic_Call -- + ------------------------- + + procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id) is + + procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind); + -- Evaluate an intrinsic shift call N on the given subprogram E. + -- Op is the kind for the shift node. + + ---------------- + -- Eval_Shift -- + ---------------- + + procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind) is + Left : constant Node_Id := First_Actual (N); + Right : constant Node_Id := Next_Actual (Left); + Static : constant Boolean := Is_Static_Function (E); + + begin + if Static then + if Checking_Potentially_Static_Expression then + Fold_Dummy (N, Etype (N)); + return; + end if; + end if; + + Fold_Shift + (N, Left, Right, Op, Static => Static, Check_Elab => not Static); + end Eval_Shift; + + Nam : Name_Id; + + begin + -- Nothing to do if the intrinsic is handled by the back end. + + if Present (Interface_Name (E)) then + return; + end if; + + -- Intrinsic calls as part of a static function is a language extension. + + if Checking_Potentially_Static_Expression + and then not Extensions_Allowed + then + return; + end if; + + -- If we have a renaming, expand the call to the original operation, + -- which must itself be intrinsic, since renaming requires matching + -- conventions and this has already been checked. + + if Present (Alias (E)) then + Eval_Intrinsic_Call (N, Alias (E)); + return; + end if; + + -- If the intrinsic subprogram is generic, gets its original name + + if Present (Parent (E)) + and then Present (Generic_Parent (Parent (E))) + then + Nam := Chars (Generic_Parent (Parent (E))); + else + Nam := Chars (E); + end if; + + case Nam is + when Name_Shift_Left => Eval_Shift (N, E, N_Op_Shift_Left); + when Name_Shift_Right => Eval_Shift (N, E, N_Op_Shift_Right); + when others => null; + end case; + end Eval_Intrinsic_Call; + --------------------- -- Eval_Logical_Op -- --------------------- @@ -2932,7 +2986,9 @@ package body Sem_Eval is To_Bits (Right_Int, Right_Bits); -- Note: should really be able to use array ops instead of - -- these loops, but they weren't working at the time ??? + -- these loops, but they break the build with a cryptic error + -- during the bind of gnat1 likely due to a wrong computation + -- of a date or checksum. if Nkind (N) = N_Op_And then for J in Left_Bits'Range loop @@ -3661,7 +3717,7 @@ package body Sem_Eval is if Is_Array_Type (Left_Typ) and then Left_Typ /= Any_Composite and then Number_Dimensions (Left_Typ) = 1 - and then Nkind_In (N, N_Op_Eq, N_Op_Ne) + and then Nkind (N) in N_Op_Eq | N_Op_Ne then if Raises_Constraint_Error (Left) or else @@ -3716,7 +3772,7 @@ package body Sem_Eval is if Is_String_Type (Left_Typ) then if Ada_Version < Ada_2020 and then (Comes_From_Source (N) - or else not Nkind_In (N, N_Op_Eq, N_Op_Ne)) + or else Nkind (N) not in N_Op_Eq | N_Op_Ne) then Is_Static_Expression := False; Set_Is_Static_Expression (N, False); @@ -3761,16 +3817,13 @@ package body Sem_Eval is -- Eval_Shift -- ---------------- - -- Shift operations are intrinsic operations that can never be static, so - -- the only processing required is to perform the required check for a non - -- static context for the two operands. - - -- Actually we could do some compile time evaluation here some time ??? - procedure Eval_Shift (N : Node_Id) is begin - Check_Non_Static_Context (Left_Opnd (N)); - Check_Non_Static_Context (Right_Opnd (N)); + -- This procedure is only called for compiler generated code (e.g. + -- packed arrays), so there is nothing to do except attempting to fold + -- the expression. + + Fold_Shift (N, Left_Opnd (N), Right_Opnd (N), Nkind (N)); end Eval_Shift; ------------------------ @@ -4688,6 +4741,96 @@ package body Sem_Eval is end if; end Flag_Non_Static_Expr; + ---------------- + -- Fold_Dummy -- + ---------------- + + procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id) is + begin + if Is_Integer_Type (Typ) then + Fold_Uint (N, Uint_1, Static => True); + + elsif Is_Real_Type (Typ) then + Fold_Ureal (N, Ureal_1, Static => True); + + elsif Is_Enumeration_Type (Typ) then + Fold_Uint + (N, + Expr_Value (Type_Low_Bound (Base_Type (Typ))), + Static => True); + + elsif Is_String_Type (Typ) then + Fold_Str + (N, + Strval (Make_String_Literal (Sloc (N), "")), + Static => True); + end if; + end Fold_Dummy; + + ---------------- + -- Fold_Shift -- + ---------------- + + procedure Fold_Shift + (N : Node_Id; + Left : Node_Id; + Right : Node_Id; + Op : Node_Kind; + Static : Boolean := False; + Check_Elab : Boolean := False) + is + Typ : constant Entity_Id := Etype (Left); + + procedure Check_Elab_Call; + -- Add checks related to calls in elaboration code + + --------------------- + -- Check_Elab_Call -- + --------------------- + + procedure Check_Elab_Call is + begin + if Check_Elab then + if Legacy_Elaboration_Checks then + Check_Elab_Call (N); + end if; + + Build_Call_Marker (N); + end if; + end Check_Elab_Call; + + begin + -- Evaluate logical shift operators on binary modular types + + if Is_Modular_Integer_Type (Typ) + and then not Non_Binary_Modulus (Typ) + and then Compile_Time_Known_Value (Left) + and then Compile_Time_Known_Value (Right) + then + if Op = N_Op_Shift_Left then + Check_Elab_Call; + + -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus + + Fold_Uint + (N, + (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right))) + rem Modulus (Typ), + Static => Static); + + elsif Op = N_Op_Shift_Right then + Check_Elab_Call; + + -- Fold Shift_Right (X, Y) by computing X / 2**Y + + Fold_Uint + (N, + Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)), + Static => Static); + end if; + end if; + end Fold_Shift; + -------------- -- Fold_Str -- -------------- @@ -4859,7 +5002,7 @@ package body Sem_Eval is function Get_String_Val (N : Node_Id) return Node_Id is begin - if Nkind_In (N, N_String_Literal, N_Character_Literal) then + if Nkind (N) in N_String_Literal | N_Character_Literal then return N; else pragma Assert (Is_Entity_Name (N)); @@ -6447,8 +6590,8 @@ package body Sem_Eval is if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then return False; - elsif Ekind_In (T1, E_Access_Subprogram_Type, - E_Anonymous_Access_Subprogram_Type) + elsif Ekind (T1) in E_Access_Subprogram_Type + | E_Anonymous_Access_Subprogram_Type then return Subtype_Conformant @@ -7156,9 +7299,8 @@ package body Sem_Eval is -- Flag array cases elsif Is_Array_Type (E) then - if not Nam_In (Attribute_Name (N), Name_First, - Name_Last, - Name_Length) + if Attribute_Name (N) + not in Name_First | Name_Last | Name_Length then Error_Msg_N ("!static array attribute must be Length, First, or Last " diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 97160ee..76e4bdf 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -427,8 +427,6 @@ package Sem_Eval is -- for compile time evaluation purposes. Use Compile_Time_Known_Value -- instead (see section on "Compile-Time Known Values" above). - -- WARNING: There is a matching C declaration of this subprogram in fe.h - function Is_OK_Static_Range (N : Node_Id) return Boolean; -- Determines if range is static, as defined in RM 4.9(26), and also checks -- that neither bound of the range raises constraint error, thus ensuring diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index fcb9ce3..15bb146 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -76,7 +76,7 @@ package body Sem_Intr is procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is begin - if not Ekind_In (E, E_Function, E_Generic_Function) then + if Ekind (E) not in E_Function | E_Generic_Function then Errint ("intrinsic exception subprogram must be a function", E, N); @@ -129,9 +129,9 @@ package body Sem_Intr is -- literal is legal even in Ada 83 mode, where such literals are -- not static. - if Nam_In (Cnam, Name_Import_Address, - Name_Import_Largest_Value, - Name_Import_Value) + if Cnam in Name_Import_Address + | Name_Import_Largest_Value + | Name_Import_Value then if Etype (Arg1) = Any_Type or else Raises_Constraint_Error (Arg1) @@ -190,13 +190,14 @@ package body Sem_Intr is begin -- Arithmetic operators - if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply, - Name_Op_Divide, Name_Op_Rem, Name_Op_Mod, Name_Op_Abs) + if Nam in Name_Op_Add | Name_Op_Subtract | Name_Op_Multiply | + Name_Op_Divide | Name_Op_Rem | Name_Op_Mod | + Name_Op_Abs then T1 := Etype (First_Formal (E)); if No (Next_Formal (First_Formal (E))) then - if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Abs) then + if Nam in Name_Op_Add | Name_Op_Subtract | Name_Op_Abs then T2 := T1; -- Previous error in declaration @@ -231,8 +232,8 @@ package body Sem_Intr is -- Comparison operators - elsif Nam_In (Nam, Name_Op_Eq, Name_Op_Ge, Name_Op_Gt, Name_Op_Le, - Name_Op_Lt, Name_Op_Ne) + elsif Nam in Name_Op_Eq | Name_Op_Ge | Name_Op_Gt | Name_Op_Le | + Name_Op_Lt | Name_Op_Ne then T1 := Etype (First_Formal (E)); @@ -327,8 +328,8 @@ package body Sem_Intr is -- Shift cases. We allow user specification of intrinsic shift operators -- for any numeric types. - elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left, - Name_Shift_Right, Name_Shift_Right_Arithmetic) + elsif Nam in Name_Rotate_Left | Name_Rotate_Right | Name_Shift_Left | + Name_Shift_Right | Name_Shift_Right_Arithmetic then Check_Shift (E, N); @@ -344,9 +345,9 @@ package body Sem_Intr is -- Exception functions - elsif Nam_In (Nam, Name_Exception_Information, - Name_Exception_Message, - Name_Exception_Name) + elsif Nam in Name_Exception_Information + | Name_Exception_Message + | Name_Exception_Name then Check_Exception_Function (E, N); @@ -357,13 +358,13 @@ package body Sem_Intr is -- Source_Location and navigation functions - elsif Nam_In (Nam, Name_File, - Name_Line, - Name_Source_Location, - Name_Enclosing_Entity, - Name_Compilation_ISO_Date, - Name_Compilation_Date, - Name_Compilation_Time) + elsif Nam in Name_File + | Name_Line + | Name_Source_Location + | Name_Enclosing_Entity + | Name_Compilation_ISO_Date + | Name_Compilation_Date + | Name_Compilation_Time then null; @@ -388,7 +389,7 @@ package body Sem_Intr is Ptyp2 : Node_Id; begin - if not Ekind_In (E, E_Function, E_Generic_Function) then + if Ekind (E) not in E_Function | E_Generic_Function then Errint ("intrinsic shift subprogram must be a function", E, N); return; end if; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index 0c6c822..4130cd8 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -230,8 +230,8 @@ package body Sem_Mech is -- OUT and IN OUT parameters of record types are passed -- by reference regardless of pragmas (RM B.3 (69/2)). - elsif Ekind_In (Formal, E_Out_Parameter, - E_In_Out_Parameter) + elsif Ekind (Formal) in + E_Out_Parameter | E_In_Out_Parameter then Set_Mechanism (Formal, By_Reference); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 24053d5..b7148d80 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -697,8 +697,8 @@ package body Sem_Prag is elsif Ekind (Item_Id) = E_Constant then Add_Str_To_Name_Buffer ("constant"); - elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, - E_Generic_In_Parameter) + elsif Ekind (Item_Id) in + E_Generic_In_Out_Parameter | E_Generic_In_Parameter then Add_Str_To_Name_Buffer ("generic parameter"); @@ -972,32 +972,32 @@ package body Sem_Prag is -- Constants - if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter) + if Ekind (Item_Id) in E_Constant | E_Loop_Parameter or else -- Current instances of concurrent types - Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) + Ekind (Item_Id) in E_Protected_Type | E_Task_Type or else -- Formal parameters - Ekind_In (Item_Id, E_Generic_In_Out_Parameter, - E_Generic_In_Parameter, - E_In_Parameter, - E_In_Out_Parameter, - E_Out_Parameter) + Ekind (Item_Id) in E_Generic_In_Out_Parameter + | E_Generic_In_Parameter + | E_In_Parameter + | E_In_Out_Parameter + | E_Out_Parameter or else -- States, variables - Ekind_In (Item_Id, E_Abstract_State, E_Variable) + Ekind (Item_Id) in E_Abstract_State | E_Variable then -- A [generic] function is not allowed to have Output -- items in its dependency relations. Note that "null" -- and attribute 'Result are still valid items. - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) + if Ekind (Spec_Id) in E_Function | E_Generic_Function and then not Is_Input then SPARK_Msg_N @@ -1009,7 +1009,7 @@ package body Sem_Prag is -- they behave as objects in the context of pragma -- [Refined_]Depends. - if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then + if Ekind (Item_Id) in E_Protected_Type | E_Task_Type then -- This use is legal as long as the concurrent type is -- the current instance of an enclosing type. @@ -1144,9 +1144,9 @@ package body Sem_Prag is Ref => Item); end if; - if Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Variable) + if Ekind (Item_Id) in E_Abstract_State + | E_Constant + | E_Variable and then Present (Encapsulating_State (Item_Id)) then Append_New_Elmt (Item_Id, Constits_Seen); @@ -1222,7 +1222,7 @@ package body Sem_Prag is procedure Check_Function_Return is begin - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) + if Ekind (Spec_Id) in E_Function | E_Generic_Function and then not Result_Seen then SPARK_Msg_NE @@ -1269,9 +1269,9 @@ package body Sem_Prag is Adjusted_Kind : Entity_Kind := Ekind (Item_Id); begin - if Ekind_In (Item_Id, E_Constant, - E_Generic_In_Parameter, - E_In_Parameter) + if Ekind (Item_Id) in E_Constant + | E_Generic_In_Parameter + | E_In_Parameter and then Is_Access_Type (Etype (Item_Id)) then Adjusted_Kind := E_Variable; @@ -2280,7 +2280,7 @@ package body Sem_Prag is -- the current instance of an enclosing protected or task type -- (SPARK RM 6.1.4). - elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then + elsif Ekind (Item_Id) in E_Protected_Type | E_Task_Type then if Is_CCT_Instance (Item_Id, Spec_Id) then -- Pragma [Refined_]Global associated with a protected @@ -2367,10 +2367,10 @@ package body Sem_Prag is -- The only legal references are those to abstract states, -- objects and various kinds of constants (SPARK RM 6.1.4(4)). - elsif not Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Loop_Parameter, - E_Variable) + elsif Ekind (Item_Id) not in E_Abstract_State + | E_Constant + | E_Loop_Parameter + | E_Variable then SPARK_Msg_N ("global item must denote object, state or current " @@ -2414,7 +2414,7 @@ package body Sem_Prag is -- nonvolatile function (SPARK RM 7.1.3(8)). elsif Is_External_State (Item_Id) - and then Ekind_In (Spec_Id, E_Function, E_Generic_Function) + and then Ekind (Spec_Id) in E_Function | E_Generic_Function and then not Is_Volatile_Function (Spec_Id) then SPARK_Msg_NE @@ -2441,7 +2441,7 @@ package body Sem_Prag is -- Unless it is of an access type, a constant is a read-only -- item, therefore it cannot act as an output. - if Nam_In (Global_Mode, Name_In_Out, Name_Output) then + if Global_Mode in Name_In_Out | Name_Output then SPARK_Msg_NE ("constant & cannot act as output", Item, Item_Id); return; @@ -2454,7 +2454,7 @@ package body Sem_Prag is -- A loop parameter is a read-only item, therefore it cannot -- act as an output. - if Nam_In (Global_Mode, Name_In_Out, Name_Output) then + if Global_Mode in Name_In_Out | Name_Output then SPARK_Msg_NE ("loop parameter & cannot act as output", Item, Item_Id); @@ -2472,7 +2472,7 @@ package body Sem_Prag is -- An effectively volatile object cannot appear as a global -- item of a nonvolatile function (SPARK RM 7.1.3(8)). - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) + if Ekind (Spec_Id) in E_Function | E_Generic_Function and then not Is_Volatile_Function (Spec_Id) then Error_Msg_NE @@ -2515,7 +2515,7 @@ package body Sem_Prag is -- Verify that an output does not appear as an input in an -- enclosing subprogram. - if Nam_In (Global_Mode, Name_In_Out, Name_Output) then + if Global_Mode in Name_In_Out | Name_Output then Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id); end if; @@ -2546,7 +2546,7 @@ package body Sem_Prag is Ref => Item); end if; - if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable) + if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable and then Present (Encapsulating_State (Item_Id)) then Append_New_Elmt (Item_Id, Constits_Seen); @@ -2650,7 +2650,7 @@ package body Sem_Prag is procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is begin - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then + if Ekind (Spec_Id) in E_Function | E_Generic_Function then SPARK_Msg_N ("global mode & is not applicable to functions", Mode); end if; @@ -2670,9 +2670,9 @@ package body Sem_Prag is -- Single global item declaration - elsif Nkind_In (List, N_Expanded_Name, - N_Identifier, - N_Selected_Component) + elsif Nkind (List) in N_Expanded_Name + | N_Identifier + | N_Selected_Component then Analyze_Global_Item (List, Global_Mode); @@ -2927,9 +2927,8 @@ package body Sem_Prag is Item_Id := Entity_Of (Item); if Present (Item_Id) - and then Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Variable) + and then Ekind (Item_Id) in + E_Abstract_State | E_Constant | E_Variable then -- When the initialization item is undefined, it appears as -- Any_Id. Do not continue with the analysis of the item. @@ -3039,16 +3038,16 @@ package body Sem_Prag is Input_Id := Entity_Of (Input); if Present (Input_Id) - and then Ekind_In (Input_Id, E_Abstract_State, - E_Constant, - E_Generic_In_Out_Parameter, - E_Generic_In_Parameter, - E_In_Parameter, - E_In_Out_Parameter, - E_Out_Parameter, - E_Protected_Type, - E_Task_Type, - E_Variable) + and then Ekind (Input_Id) in E_Abstract_State + | E_Constant + | E_Generic_In_Out_Parameter + | E_Generic_In_Parameter + | E_In_Parameter + | E_In_Out_Parameter + | E_Out_Parameter + | E_Protected_Type + | E_Task_Type + | E_Variable then -- The input cannot denote states or objects declared -- within the related package (SPARK RM 7.1.5(4)). @@ -3061,12 +3060,12 @@ package body Sem_Prag is -- it is allowed for an initialization item to depend -- on an input item. - if Ekind_In (Input_Id, E_Generic_In_Out_Parameter, - E_Generic_In_Parameter) + if Ekind (Input_Id) in E_Generic_In_Out_Parameter + | E_Generic_In_Parameter then null; - elsif Ekind_In (Input_Id, E_Constant, E_Variable) + elsif Ekind (Input_Id) in E_Constant | E_Variable and then Present (Corresponding_Generic_Association (Declaration_Node (Input_Id))) then @@ -3098,9 +3097,9 @@ package body Sem_Prag is Append_New_Elmt (Input_Id, States_Seen); end if; - if Ekind_In (Input_Id, E_Abstract_State, - E_Constant, - E_Variable) + if Ekind (Input_Id) in E_Abstract_State + | E_Constant + | E_Variable and then Present (Encapsulating_State (Input_Id)) then Append_New_Elmt (Input_Id, Constits_Seen); @@ -3201,8 +3200,8 @@ package body Sem_Prag is Decl := First (Visible_Declarations (Pack_Spec)); while Present (Decl) loop if Comes_From_Source (Decl) - and then Nkind_In (Decl, N_Object_Declaration, - N_Object_Renaming_Declaration) + and then Nkind (Decl) in N_Object_Declaration + | N_Object_Renaming_Declaration then Append_New_Elmt (Defining_Entity (Decl), States_And_Objs); @@ -3508,7 +3507,7 @@ package body Sem_Prag is -- Only abstract states and variables can act as constituents of an -- encapsulating single concurrent type. - if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + if Ekind (Item_Id) in E_Abstract_State | E_Variable then null; -- The constituent is a constant @@ -3551,9 +3550,9 @@ package body Sem_Prag is -- the single concurrent type (SPARK RM 9(3)). if Item_Context = Encap_Context then - if Nkind_In (Item_Context, N_Package_Specification, - N_Protected_Definition, - N_Task_Definition) + if Nkind (Item_Context) in N_Package_Specification + | N_Protected_Definition + | N_Task_Definition then Prv_Decls := Private_Declarations (Item_Context); Vis_Decls := Visible_Declarations (Item_Context); @@ -3638,9 +3637,8 @@ package body Sem_Prag is Encap_Id := Empty; Legal := False; - if Nkind_In (Encap, N_Expanded_Name, - N_Identifier, - N_Selected_Component) + if Nkind (Encap) in + N_Expanded_Name | N_Identifier | N_Selected_Component then Analyze (Encap); Resolve_State (Encap); @@ -3789,7 +3787,8 @@ package body Sem_Prag is Arg2 : Node_Id; Arg3 : Node_Id; Arg4 : Node_Id; - -- First four pragma arguments (pragma argument association nodes, or + Arg5 : Node_Id; + -- First five pragma arguments (pragma argument association nodes, or -- Empty if the corresponding argument does not exist). type Name_List is array (Natural range <>) of Name_Id; @@ -4629,12 +4628,12 @@ package body Sem_Prag is -- original pragma name by routine Original_Aspect_Pragma_Name. if Comes_From_Source (N) then - if Nam_In (Pname, Name_Pre, Name_Pre_Class) then + if Pname in Name_Pre | Name_Pre_Class then Is_Pre_Post := True; Set_Class_Present (N, Pname = Name_Pre_Class); Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition)); - elsif Nam_In (Pname, Name_Post, Name_Post_Class) then + elsif Pname in Name_Post | Name_Post_Class then Is_Pre_Post := True; Set_Class_Present (N, Pname = Name_Post_Class); Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition)); @@ -4645,7 +4644,7 @@ package body Sem_Prag is -- in a body. Pragmas Precondition and Postcondition were introduced -- before aspects and are not subject to the same aspect-like rules. - if Nam_In (Pname, Name_Precondition, Name_Postcondition) then + if Pname in Name_Precondition | Name_Postcondition then Duplicates_OK := True; In_Body_OK := True; end if; @@ -4802,9 +4801,9 @@ package body Sem_Prag is -- Fully analyze the pragma when it appears inside an entry or -- subprogram body because it cannot benefit from forward references. - if Nkind_In (Subp_Decl, N_Entry_Body, - N_Subprogram_Body, - N_Subprogram_Body_Stub) + if Nkind (Subp_Decl) in N_Entry_Body + | N_Subprogram_Body + | N_Subprogram_Body_Stub then -- The legality checks of pragmas Precondition and Postcondition -- are affected by the SPARK mode in effect and the volatility of @@ -4844,11 +4843,9 @@ package body Sem_Prag is Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); - if not Nkind_In (Body_Decl, N_Entry_Body, - N_Subprogram_Body, - N_Subprogram_Body_Stub, - N_Task_Body, - N_Task_Body_Stub) + if Nkind (Body_Decl) not in + N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub | + N_Task_Body | N_Task_Body_Stub then Pragma_Misplaced; return; @@ -4881,10 +4878,10 @@ package body Sem_Prag is -- When dealing with protected entries or protected subprograms, use -- the enclosing protected type as the proper context. - if Ekind_In (Spec_Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure) + if Ekind (Spec_Id) in E_Entry + | E_Entry_Family + | E_Function + | E_Procedure and then Ekind (Scope (Spec_Id)) = E_Protected_Type then Spec_Decl := Declaration_Node (Scope (Spec_Id)); @@ -4906,7 +4903,7 @@ package body Sem_Prag is Mark_Ghost_Pragma (N, Spec_Id); - if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then + if Pname in Name_Refined_Depends | Name_Refined_Global then Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); end if; end Analyze_Refined_Depends_Global_Post; @@ -5471,7 +5468,7 @@ package body Sem_Prag is begin Check_Arg_Is_Identifier (Argx); - if not Nam_In (Chars (Argx), N1, N2) then + if Chars (Argx) not in N1 | N2 then Error_Msg_Name_2 := N1; Error_Msg_Name_3 := N2; Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); @@ -5487,7 +5484,7 @@ package body Sem_Prag is begin Check_Arg_Is_Identifier (Argx); - if not Nam_In (Chars (Argx), N1, N2, N3) then + if Chars (Argx) not in N1 | N2 | N3 then Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; @@ -5501,7 +5498,7 @@ package body Sem_Prag is begin Check_Arg_Is_Identifier (Argx); - if not Nam_In (Chars (Argx), N1, N2, N3, N4) then + if Chars (Argx) not in N1 | N2 | N3 | N4 then Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; @@ -5515,7 +5512,7 @@ package body Sem_Prag is begin Check_Arg_Is_Identifier (Argx); - if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then + if Chars (Argx) not in N1 | N2 | N3 | N4 | N5 then Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; @@ -5898,7 +5895,7 @@ package body Sem_Prag is -- For a single protected or a single task object, the error is -- issued on the original entity. - if Ekind_In (Id, E_Task_Type, E_Protected_Type) then + if Ekind (Id) in E_Task_Type | E_Protected_Type then Id := Defining_Identifier (Original_Node (Parent (Id))); end if; @@ -5911,7 +5908,7 @@ package body Sem_Prag is -- [No_]Inline which is suspicious but not an error, generate -- an error for other pragmas. - if Nam_In (Pragma_Name (N), Name_Inline, Name_No_Inline) then + if Pragma_Name (N) in Name_Inline | Name_No_Inline then if Warn_On_Redundant_Constructs then Error_Msg_NE ("?r?pragma% for & duplicates pragma#", N, Id); @@ -6337,9 +6334,8 @@ package body Sem_Prag is if Nkind (Original_Node (Stmt)) = N_Pragma then return - Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)), - Name_Loop_Invariant, - Name_Loop_Variant); + Pragma_Name_Unmapped (Original_Node (Stmt)) + in Name_Loop_Invariant | Name_Loop_Variant; else return False; end if; @@ -6464,9 +6460,7 @@ package body Sem_Prag is elsif Nkind (P) = N_Handled_Sequence_Of_Statements then exit; - elsif Nkind_In (P, N_Package_Specification, - N_Block_Statement) - then + elsif Nkind (P) in N_Package_Specification | N_Block_Statement then return; -- Note: the following tests seem a little peculiar, because @@ -6475,10 +6469,8 @@ package body Sem_Prag is -- sequence, so the only way we get here is by being in the -- declarative part of the body. - elsif Nkind_In (P, N_Subprogram_Body, - N_Package_Body, - N_Task_Body, - N_Entry_Body) + elsif Nkind (P) in + N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body then return; end if; @@ -6976,9 +6968,9 @@ package body Sem_Prag is if Nkind (P) = N_Compilation_Unit then Unit_Kind := Nkind (Unit (P)); - if Nkind_In (Unit_Kind, N_Subprogram_Declaration, - N_Package_Declaration) - or else Unit_Kind in N_Generic_Declaration + if Unit_Kind in N_Subprogram_Declaration + | N_Package_Declaration + | N_Generic_Declaration then Unit_Name := Defining_Entity (Unit (P)); @@ -7684,12 +7676,12 @@ package body Sem_Prag is if SPARK_Mode = On and then Prag_Id = Pragma_Volatile - and then not Nkind_In (Original_Node (Decl), - N_Full_Type_Declaration, - N_Formal_Type_Declaration, - N_Object_Declaration, - N_Single_Protected_Declaration, - N_Single_Task_Declaration) + and then Nkind (Original_Node (Decl)) not in + N_Full_Type_Declaration | + N_Formal_Type_Declaration | + N_Object_Declaration | + N_Single_Protected_Declaration | + N_Single_Task_Declaration then Error_Pragma_Arg ("argument of pragma % must denote a full type or object " @@ -7771,7 +7763,7 @@ package body Sem_Prag is else while Present (P) and then Nkind (P) not in N_Generic_Declaration loop - if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then + if Nkind (P) in N_Package_Body | N_Subprogram_Body then P := Corresponding_Spec (P); else P := Parent (P); @@ -7917,17 +7909,17 @@ package body Sem_Prag is then -- Give error if same as our pragma or Export/Convention - if Nam_In (Pragma_Name_Unmapped (Decl), - Name_Export, - Name_Convention, - Pragma_Name_Unmapped (N)) + if Pragma_Name_Unmapped (Decl) + in Name_Export + | Name_Convention + | Pragma_Name_Unmapped (N) then exit; -- Case of Import/Interface or the other way round - elsif Nam_In (Pragma_Name_Unmapped (Decl), - Name_Interface, Name_Import) + elsif Pragma_Name_Unmapped (Decl) + in Name_Interface | Name_Import then -- Here we know that we have Import and Interface. It -- doesn't matter which way round they are. See if @@ -8027,9 +8019,9 @@ package body Sem_Prag is while Present (Comp) loop if Present (Etype (Comp)) and then - Ekind_In (Etype (Comp), - E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + Ekind (Etype (Comp)) in + E_Anonymous_Access_Type | + E_Anonymous_Access_Subprogram_Type and then not Has_Convention_Pragma (Comp) then Set_Convention (Comp, C); @@ -8040,9 +8032,9 @@ package body Sem_Prag is end; elsif Is_Array_Type (E) - and then Ekind_In (Component_Type (E), - E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + and then Ekind (Component_Type (E)) in + E_Anonymous_Access_Type | + E_Anonymous_Access_Subprogram_Type then Set_Convention (Designated_Type (Component_Type (E)), C); end if; @@ -8204,8 +8196,8 @@ package body Sem_Prag is E := Alias (E); - elsif Nkind_In (Parent (E), N_Full_Type_Declaration, - N_Private_Extension_Declaration) + elsif Nkind (Parent (E)) in + N_Full_Type_Declaration | N_Private_Extension_Declaration and then Scope (E) = Scope (Alias (E)) then E := Alias (E); @@ -8229,7 +8221,7 @@ package body Sem_Prag is -- Check that we are not applying this to a named constant - if Ekind_In (E, E_Named_Integer, E_Named_Real) then + if Ekind (E) in E_Named_Integer | E_Named_Real then Error_Msg_Name_1 := Pname; Error_Msg_N ("cannot apply pragma% to named constant!", @@ -8585,7 +8577,7 @@ package body Sem_Prag is Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Def_Id := Entity (Arg_Internal); - if not Ekind_In (Def_Id, E_Constant, E_Variable) then + if Ekind (Def_Id) not in E_Constant | E_Variable then Error_Pragma_Arg ("pragma% must designate an object", Arg_Internal); end if; @@ -8810,8 +8802,8 @@ package body Sem_Prag is Match := False; elsif Etype (Def_Id) /= Standard_Void_Type - and then Nam_In (Pname, Name_Export_Procedure, - Name_Import_Procedure) + and then + Pname in Name_Export_Procedure | Name_Import_Procedure then Match := False; @@ -9222,7 +9214,7 @@ package body Sem_Prag is -- Various error checks - if Ekind_In (Def_Id, E_Variable, E_Constant) then + if Ekind (Def_Id) in E_Variable | E_Constant then -- We do not permit Import to apply to a renaming declaration @@ -9721,9 +9713,9 @@ package body Sem_Prag is -- pragma Inline_Always (Proc); -- end Pack; - elsif Nkind_In (Context, N_Package_Specification, - N_Protected_Definition, - N_Task_Definition) + elsif Nkind (Context) in N_Package_Specification + | N_Protected_Definition + | N_Task_Definition and then Init_List = Visible_Declarations (Context) and then Prag_List = Private_Declarations (Context) then @@ -10542,23 +10534,28 @@ package body Sem_Prag is Set_Global_No_Tasking; end if; - -- If this is a warning, then set the warning unless we already - -- have a real restriction active (we never want a warning to - -- override a real restriction). + Set_Restriction (R_Id, N, Warn); - if Warn then - if not Restriction_Active (R_Id) then - Set_Restriction (R_Id, N); - Restriction_Warnings (R_Id) := True; - end if; + if R_Id = No_Dynamic_CPU_Assignment + or else R_Id = No_Tasks_Unassigned_To_CPU + then + -- These imply No_Dependence => + -- "System.Multiprocessors.Dispatching_Domains". + -- This is not strictly what the AI says, but it eliminates + -- the need for run-time checks, which are undesirable in + -- this context. - -- If real restriction case, then set it and make sure that the - -- restriction warning flag is off, since a real restriction - -- always overrides a warning. + Set_Restriction_No_Dependence + (Sel_Comp + (Sel_Comp ("system", "multiprocessors", Loc), + "dispatching_domains"), + Warn); + end if; - else - Set_Restriction (R_Id, N); - Restriction_Warnings (R_Id) := False; + if R_Id = No_Tasks_Unassigned_To_CPU then + -- Likewise, imply No_Dynamic_CPU_Assignment + + Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn); end if; -- Check for obsolescent restrictions in Ada 2005 mode @@ -10702,26 +10699,7 @@ package body Sem_Prag is ("pragma ignored, value too large??", Arg); end if; - -- Warning case. If the real restriction is active, then we - -- ignore the request, since warning never overrides a real - -- restriction. Otherwise we set the proper warning. Note that - -- this circuit sets the warning again if it is already set, - -- which is what we want, since the constant may have changed. - - if Warn then - if not Restriction_Active (R_Id) then - Set_Restriction - (R_Id, N, Integer (UI_To_Int (Val))); - Restriction_Warnings (R_Id) := True; - end if; - - -- Real restriction case, set restriction and make sure warning - -- flag is off since real restriction always overrides warning. - - else - Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); - Restriction_Warnings (R_Id) := False; - end if; + Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val))); end if; Next (Arg); @@ -11313,13 +11291,6 @@ package body Sem_Prag is Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); end Set_Error_Msg_To_Profile_Name; - -- Local variables - - Nod : Node_Id; - Pref : Node_Id; - Pref_Id : Node_Id; - Sel_Id : Node_Id; - Profile_Dispatching_Policy : Character; -- Start of processing for Set_Ravenscar_Profile @@ -11391,46 +11362,30 @@ package body Sem_Prag is -- No_Dependence => Ada.Calendar -- No_Dependence => Ada.Task_Attributes -- are already set by previous call to Set_Profile_Restrictions. + -- Really??? -- Set the following restrictions which were added to Ada 2005: -- No_Dependence => Ada.Execution_Time.Group_Budget -- No_Dependence => Ada.Execution_Time.Timers if Ada_Version >= Ada_2005 then - Pref_Id := Make_Identifier (Loc, Name_Find ("ada")); - Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time")); - - Pref := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref_Id, - Selector_Name => Sel_Id); - - Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets")); - - Nod := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref, - Selector_Name => Sel_Id); - - Set_Restriction_No_Dependence - (Unit => Nod, - Warn => Treat_Restrictions_As_Warnings, - Profile => Ravenscar); - - Sel_Id := Make_Identifier (Loc, Name_Find ("timers")); - - Nod := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref, - Selector_Name => Sel_Id); - - Set_Restriction_No_Dependence - (Unit => Nod, - Warn => Treat_Restrictions_As_Warnings, - Profile => Ravenscar); + declare + Execution_Time : constant Node_Id := + Sel_Comp ("ada", "execution_time", Loc); + Group_Budgets : constant Node_Id := + Sel_Comp (Execution_Time, "group_budgets"); + Timers : constant Node_Id := + Sel_Comp (Execution_Time, "timers"); + begin + Set_Restriction_No_Dependence + (Unit => Group_Budgets, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + Set_Restriction_No_Dependence + (Unit => Timers, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + end; end if; -- Set the following restriction which was added to Ada 2012 (see @@ -11438,25 +11393,10 @@ package body Sem_Prag is -- No_Dependence => System.Multiprocessors.Dispatching_Domains if Ada_Version >= Ada_2012 then - Pref_Id := Make_Identifier (Loc, Name_Find ("system")); - Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors")); - - Pref := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref_Id, - Selector_Name => Sel_Id); - - Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains")); - - Nod := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref, - Selector_Name => Sel_Id); - Set_Restriction_No_Dependence - (Unit => Nod, + (Sel_Comp + (Sel_Comp ("system", "multiprocessors", Loc), + "dispatching_domains"), Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); @@ -11468,18 +11408,8 @@ package body Sem_Prag is -- in Ada2012 (AI05-0174). if Profile /= Jorvik then - Pref_Id := Make_Identifier (Loc, Name_Find ("ada")); - Sel_Id := Make_Identifier (Loc, Name_Find - ("synchronous_barriers")); - - Nod := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref_Id, - Selector_Name => Sel_Id); - Set_Restriction_No_Dependence - (Unit => Nod, + (Sel_Comp ("ada", "synchronous_barriers", Loc), Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); end if; @@ -11597,6 +11527,7 @@ package body Sem_Prag is Arg2 := Empty; Arg3 := Empty; Arg4 := Empty; + Arg5 := Empty; if Present (Pragma_Argument_Associations (N)) then Arg_Count := List_Length (Pragma_Argument_Associations (N)); @@ -11610,6 +11541,10 @@ package body Sem_Prag is if Present (Arg3) then Arg4 := Next (Arg3); + + if Present (Arg4) then + Arg5 := Next (Arg4); + end if; end if; end if; end if; @@ -11900,10 +11835,10 @@ package body Sem_Prag is -- external properties. elsif Nkind (Prop) = N_Identifier - and then Nam_In (Chars (Prop), Name_Async_Readers, - Name_Async_Writers, - Name_Effective_Reads, - Name_Effective_Writes) + and then Chars (Prop) in Name_Async_Readers + | Name_Async_Writers + | Name_Effective_Reads + | Name_Effective_Writes then null; @@ -12380,8 +12315,8 @@ package body Sem_Prag is Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); - if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (Pack_Decl) not in + N_Generic_Package_Declaration | N_Package_Declaration then Pragma_Misplaced; return; @@ -13216,9 +13151,7 @@ package body Sem_Prag is -- The Ghost policy must be either Check or Ignore -- (SPARK RM 6.9(6)). - if not Nam_In (Chars (Policy), Name_Check, - Name_Ignore) - then + if Chars (Policy) not in Name_Check | Name_Ignore then Error_Pragma_Arg ("argument of pragma % Ghost must be Check or " & "Ignore", Policy); @@ -13366,12 +13299,12 @@ package body Sem_Prag is if Nkind (Obj_Or_Type_Decl) /= N_Object_Declaration then if Prag_Id = Pragma_No_Caching - or not Nkind_In (Original_Node (Obj_Or_Type_Decl), - N_Full_Type_Declaration, - N_Private_Type_Declaration, - N_Formal_Type_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration) + or else Nkind (Original_Node (Obj_Or_Type_Decl)) not in + N_Full_Type_Declaration | + N_Private_Type_Declaration | + N_Formal_Type_Declaration | + N_Task_Type_Declaration | + N_Protected_Type_Declaration then Pragma_Misplaced; return; @@ -13626,9 +13559,7 @@ package body Sem_Prag is if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E)) or else (Nkind (D) = N_Object_Declaration - and then (Ekind (E) = E_Constant - or else - Ekind (E) = E_Variable) + and then Ekind (E) in E_Constant | E_Variable and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition) or else @@ -14061,7 +13992,7 @@ package body Sem_Prag is -- identifier is Name. if Nkind (Arg1) /= N_Pragma_Argument_Association - or else Nam_In (Chars (Arg1), No_Name, Name_Name) + or else Chars (Arg1) in No_Name | Name_Name then -- Old syntax @@ -14074,7 +14005,7 @@ package body Sem_Prag is -- Check forbidden check kind - if Nam_In (Chars (Kind), Name_Name, Name_Policy) then + if Chars (Kind) in Name_Name | Name_Policy then Error_Msg_Name_2 := Chars (Kind); Error_Pragma_Arg ("pragma% does not allow% as check name", Arg1); @@ -14258,7 +14189,7 @@ package body Sem_Prag is -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); when Pragma_Complex_Representation => Complex_Representation : declare - E_Id : Entity_Id; + E_Id : Node_Id; E : Entity_Id; Ent : Entity_Id; @@ -14597,9 +14528,9 @@ package body Sem_Prag is -- or subprogram body because it cannot benefit from forward -- references. - if Nkind_In (Subp_Decl, N_Entry_Body, - N_Subprogram_Body, - N_Subprogram_Body_Stub) + if Nkind (Subp_Decl) in N_Entry_Body + | N_Subprogram_Body + | N_Subprogram_Body_Stub then -- The legality checks of pragma Contract_Cases are affected by -- the SPARK mode in effect and the volatility of the context. @@ -14829,6 +14760,140 @@ package body Sem_Prag is & "effect?j?", N); end if; + -------------------- + -- CUDA_Execute -- + -------------------- + + -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT, + -- EXPRESSION, + -- EXPRESSION, + -- [, EXPRESSION + -- [, EXPRESSION]]); + + when Pragma_CUDA_Execute => CUDA_Execute : declare + + function Is_Acceptable_Dim3 (N : Node_Id) return Boolean; + -- Returns True if N is an acceptable argument for CUDA_Execute, + -- false otherwise. + + ------------------------ + -- Is_Acceptable_Dim3 -- + ------------------------ + + function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is + Tmp : Node_Id; + begin + if Etype (N) = RTE (RE_Dim3) or else Is_Integer_Type (Etype (N)) + then + return True; + end if; + + if Nkind (N) = N_Aggregate + and then List_Length (Expressions (N)) = 3 + then + Tmp := First (Expressions (N)); + while Present (Tmp) loop + Analyze_And_Resolve (Tmp, Any_Integer); + Tmp := Next (Tmp); + end loop; + return True; + end if; + + return False; + end Is_Acceptable_Dim3; + + -- Local variables + + Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3); + Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2); + Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1); + Shared_Memory : Node_Id; + Stream : Node_Id; + + -- Start of processing for CUDA_Execute + + begin + + GNAT_Pragma; + Check_At_Least_N_Arguments (3); + Check_At_Most_N_Arguments (5); + + Analyze_And_Resolve (Kernel_Call); + if Nkind (Kernel_Call) /= N_Function_Call + or else Etype (Kernel_Call) /= Standard_Void_Type + then + -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`, + -- GNAT sees Kernel_Call as an N_Function_Call since + -- Kernel_Call "looks" like an expression. However, only + -- procedures can be kernels, so to make things easier for the + -- user the error message complains about Kernel_Call not being + -- a procedure call. + + Error_Msg_N ("first argument of & must be a procedure call", N); + end if; + + Analyze (Grid_Dimensions); + if not Is_Acceptable_Dim3 (Grid_Dimensions) then + Error_Msg_N + ("second argument of & must be an Integer, Dim3 or aggregate " + & "containing 3 Integers", N); + end if; + + Analyze (Block_Dimensions); + if not Is_Acceptable_Dim3 (Block_Dimensions) then + Error_Msg_N + ("third argument of & must be an Integer, Dim3 or aggregate " + & "containing 3 Integers", N); + end if; + + if Present (Arg4) then + Shared_Memory := Get_Pragma_Arg (Arg4); + Analyze_And_Resolve (Shared_Memory, Any_Integer); + + if Present (Arg5) then + Stream := Get_Pragma_Arg (Arg5); + Analyze_And_Resolve (Stream, RTE (RE_Stream_T)); + end if; + end if; + end CUDA_Execute; + + ----------------- + -- CUDA_Global -- + ----------------- + + -- pragma CUDA_Global (IDENTIFIER); + + when Pragma_CUDA_Global => CUDA_Global : declare + Arg_Node : Node_Id; + Kernel_Proc : Entity_Id; + Pack_Id : Entity_Id; + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + + Arg_Node := Get_Pragma_Arg (Arg1); + Analyze (Arg_Node); + + Kernel_Proc := Entity (Arg_Node); + Pack_Id := Scope (Kernel_Proc); + + if Ekind (Kernel_Proc) /= E_Procedure then + Error_Msg_NE ("& must be a procedure", N, Kernel_Proc); + + elsif Ekind (Pack_Id) /= E_Package + or else not Is_Library_Level_Entity (Pack_Id) + then + Error_Msg_NE + ("& must reside in a library-level package", N, Kernel_Proc); + + else + Set_Is_CUDA_Kernel (Kernel_Proc); + end if; + end CUDA_Global; + ---------------- -- CPP_Vtable -- ---------------- @@ -14857,13 +14922,13 @@ package body Sem_Prag is Ada_2012_Pragma; Check_No_Identifiers; Check_Arg_Count (1); + Arg := Get_Pragma_Arg (Arg1); -- Subprogram case if Nkind (P) = N_Subprogram_Body then Check_In_Main_Program; - Arg := Get_Pragma_Arg (Arg1); Analyze_And_Resolve (Arg, Any_Integer); Ent := Defining_Unit_Name (Specification (P)); @@ -14910,7 +14975,6 @@ package body Sem_Prag is -- Task case elsif Nkind (P) = N_Task_Definition then - Arg := Get_Pragma_Arg (Arg1); Ent := Defining_Identifier (Parent (P)); -- The expression must be analyzed in the special manner @@ -14919,6 +14983,16 @@ package body Sem_Prag is Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); + -- See comment in Sem_Ch13 about the following restrictions + + if Is_OK_Static_Expression (Arg) then + if Expr_Value (Arg) = Uint_0 then + Check_Restriction (No_Tasks_Unassigned_To_CPU, N); + end if; + else + Check_Restriction (No_Dynamic_CPU_Assignment, N); + end if; + -- Anything else is incorrect else @@ -15007,11 +15081,11 @@ package body Sem_Prag is Call := Get_Pragma_Arg (Arg1); end if; - if Nkind_In (Call, N_Expanded_Name, - N_Function_Call, - N_Identifier, - N_Indexed_Component, - N_Selected_Component) + if Nkind (Call) in N_Expanded_Name + | N_Function_Call + | N_Identifier + | N_Indexed_Component + | N_Selected_Component then -- If this pragma Debug comes from source, its argument was -- parsed as a name form (which is syntactically identical). @@ -15146,8 +15220,8 @@ package body Sem_Prag is -- The associated private type [extension] has been found, stop -- the search. - elsif Nkind_In (Stmt, N_Private_Extension_Declaration, - N_Private_Type_Declaration) + elsif Nkind (Stmt) in N_Private_Extension_Declaration + | N_Private_Type_Declaration then Typ := Defining_Entity (Stmt); exit; @@ -15396,9 +15470,9 @@ package body Sem_Prag is -- or subprogram body because it cannot benefit from forward -- references. - if Nkind_In (Subp_Decl, N_Entry_Body, - N_Subprogram_Body, - N_Subprogram_Body_Stub) + if Nkind (Subp_Decl) in N_Entry_Body + | N_Subprogram_Body + | N_Subprogram_Body_Stub then -- The legality checks of pragmas Depends and Global are -- affected by the SPARK mode in effect and the volatility @@ -15752,8 +15826,8 @@ package body Sem_Prag is Mark_Ghost_Pragma (N, Cunit_Ent); - if Nkind_In (Unit (Cunit_Node), N_Package_Body, - N_Subprogram_Body) + if Nkind (Unit (Cunit_Node)) in + N_Package_Body | N_Subprogram_Body then Error_Pragma ("pragma% must refer to a spec, not a body"); else @@ -16727,8 +16801,8 @@ package body Sem_Prag is -- Task unit declared without a definition cannot be subject to -- pragma Ghost (SPARK RM 6.9(19)). - elsif Nkind_In (Stmt, N_Single_Task_Declaration, - N_Task_Type_Declaration) + elsif Nkind (Stmt) in + N_Single_Task_Declaration | N_Task_Type_Declaration then Error_Pragma ("pragma % cannot apply to a task type"); return; @@ -16741,8 +16815,8 @@ package body Sem_Prag is -- When pragma Ghost applies to an untagged derivation, the -- derivation is transformed into a [sub]type declaration. - if Nkind_In (Stmt, N_Full_Type_Declaration, - N_Subtype_Declaration) + if Nkind (Stmt) in + N_Full_Type_Declaration | N_Subtype_Declaration and then Comes_From_Source (Orig_Stmt) and then Nkind (Orig_Stmt) = N_Full_Type_Declaration and then Nkind (Type_Definition (Orig_Stmt)) = @@ -16776,14 +16850,14 @@ package body Sem_Prag is -- The pragma applies to a legal construct, stop the traversal - elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration, - N_Full_Type_Declaration, - N_Generic_Subprogram_Declaration, - N_Object_Declaration, - N_Private_Extension_Declaration, - N_Private_Type_Declaration, - N_Subprogram_Declaration, - N_Subtype_Declaration) + elsif Nkind (Stmt) in N_Abstract_Subprogram_Declaration + | N_Full_Type_Declaration + | N_Generic_Subprogram_Declaration + | N_Object_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Subprogram_Declaration + | N_Subtype_Declaration then Id := Defining_Entity (Stmt); exit; @@ -16812,12 +16886,12 @@ package body Sem_Prag is -- Protected and task types cannot be subject to pragma Ghost -- (SPARK RM 6.9(19)). - if Nkind_In (Context, N_Protected_Body, N_Protected_Definition) + if Nkind (Context) in N_Protected_Body | N_Protected_Definition then Error_Pragma ("pragma % cannot apply to a protected type"); return; - elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then + elsif Nkind (Context) in N_Task_Body | N_Task_Definition then Error_Pragma ("pragma % cannot apply to a task type"); return; end if; @@ -17011,9 +17085,9 @@ package body Sem_Prag is -- or subprogram body because it cannot benefit from forward -- references. - if Nkind_In (Subp_Decl, N_Entry_Body, - N_Subprogram_Body, - N_Subprogram_Body_Stub) + if Nkind (Subp_Decl) in N_Entry_Body + | N_Subprogram_Body + | N_Subprogram_Body_Stub then -- The legality checks of pragmas Depends and Global are -- affected by the SPARK mode in effect and the volatility @@ -17064,8 +17138,8 @@ package body Sem_Prag is begin GP := Parent (Parent (N)); - if Nkind_In (GP, N_Package_Declaration, - N_Generic_Package_Declaration) + if Nkind (GP) in + N_Package_Declaration | N_Generic_Package_Declaration then GP := Parent (GP); end if; @@ -17213,8 +17287,8 @@ package body Sem_Prag is -- "synchronized". or else - (Ekind_In (Typ, E_Record_Type_With_Private, - E_Record_Subtype_With_Private) + (Ekind (Typ) in E_Record_Type_With_Private + | E_Record_Subtype_With_Private and then Synchronized_Present (Parent (Typ)))) then null; @@ -17670,8 +17744,8 @@ package body Sem_Prag is Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); - if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (Pack_Decl) not in + N_Generic_Package_Declaration | N_Package_Declaration then Pragma_Misplaced; return; @@ -17942,8 +18016,8 @@ package body Sem_Prag is Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); - if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (Pack_Decl) not in + N_Generic_Package_Declaration | N_Package_Declaration then Pragma_Misplaced; return; @@ -18280,7 +18354,7 @@ package body Sem_Prag is Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); end if; - if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then + if Nkind (P) not in N_Task_Definition | N_Protected_Definition then Pragma_Misplaced; return; @@ -18479,9 +18553,9 @@ package body Sem_Prag is -- A [class-wide] invariant may be associated a [limited] private -- type or a private extension. - elsif Ekind_In (Typ, E_Limited_Private_Type, - E_Private_Type, - E_Record_Type_With_Private) + elsif Ekind (Typ) in E_Limited_Private_Type + | E_Private_Type + | E_Record_Type_With_Private then null; @@ -19132,8 +19206,7 @@ package body Sem_Prag is if Chars (Variant) = No_Name then Error_Pragma_Arg_Ident ("expect name `Increases`", Variant); - elsif not Nam_In (Chars (Variant), Name_Decreases, - Name_Increases) + elsif Chars (Variant) not in Name_Decreases | Name_Increases then declare Name : String := Get_Name_String (Chars (Variant)); @@ -19367,7 +19440,8 @@ package body Sem_Prag is -- Otherwise the pragma is associated with an illegal construct else - Error_Pragma ("pragma % must apply to a protected entry"); + Error_Pragma + ("pragma % must apply to a protected entry declaration"); return; end if; @@ -19445,11 +19519,11 @@ package body Sem_Prag is -- Must appear for a spec or generic spec - if not Nkind_In (Unit (Cunit (Current_Sem_Unit)), - N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Declaration) + if Nkind (Unit (Cunit (Current_Sem_Unit))) not in + N_Generic_Package_Declaration | + N_Generic_Subprogram_Declaration | + N_Package_Declaration | + N_Subprogram_Declaration then Error_Pragma (Fix_Error @@ -19580,7 +19654,7 @@ package body Sem_Prag is -- The pragma must apply to an access-to-object type - if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then + if Ekind (Typ) in E_Access_Type | E_General_Access_Type then null; -- Give a detailed error message on all other access type kinds @@ -19708,10 +19782,10 @@ package body Sem_Prag is loop -- Ada 2020 (AI12-0269): A function can be No_Return - if Ekind_In (E, E_Generic_Procedure, E_Procedure) + if Ekind (E) in E_Generic_Procedure | E_Procedure or else (Ada_Version >= Ada_2020 and then - Ekind_In (E, E_Generic_Function, E_Function)) + Ekind (E) in E_Generic_Function | E_Function) then -- Check that the pragma is not applied to a body. -- First check the specless body case, to give a @@ -20103,9 +20177,8 @@ package body Sem_Prag is and then (Chars (Arg1) = Name_Entity or else - Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal, - N_Identifier, - N_Operator_Symbol)) + Nkind (Get_Pragma_Arg (Arg1)) in + N_Character_Literal | N_Identifier | N_Operator_Symbol) then Ename := Get_Pragma_Arg (Arg1); @@ -20541,9 +20614,8 @@ package body Sem_Prag is -- they may not depend on variable input. This check is -- left to the SPARK prover. - elsif Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Variable) + elsif Ekind (Item_Id) in + E_Abstract_State | E_Constant | E_Variable then Has_Item := True; Constits := Part_Of_Constituents (State_Id); @@ -20860,9 +20932,9 @@ package body Sem_Prag is Check_Arg_Is_Library_Level_Local_Name (Arg1); if not Is_Entity_Name (Get_Pragma_Arg (Arg1)) - or else not - Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable, - E_Constant) + or else + Ekind (Entity (Get_Pragma_Arg (Arg1))) not in + E_Variable | E_Constant then Error_Pragma_Arg ("pragma% only applies to objects", Arg1); end if; @@ -21318,7 +21390,7 @@ package body Sem_Prag is -- Task or Protected, must be of type Integer - elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then + elsif Nkind (P) in N_Protected_Definition | N_Task_Definition then Arg := Get_Pragma_Arg (Arg1); Ent := Defining_Identifier (Parent (P)); @@ -21730,9 +21802,8 @@ package body Sem_Prag is procedure Check_Arg (Arg : Node_Id) is begin - if not Nkind_In (Original_Node (Arg), - N_String_Literal, - N_Identifier) + if Nkind (Original_Node (Arg)) not in + N_String_Literal | N_Identifier then Error_Pragma_Arg ("inappropriate argument for pragma %", Arg); @@ -21748,7 +21819,7 @@ package body Sem_Prag is Def_Id := Entity (Internal); - if not Ekind_In (Def_Id, E_Constant, E_Variable) then + if Ekind (Def_Id) not in E_Constant | E_Variable then Error_Pragma_Arg ("pragma% must designate an object", Internal); end if; @@ -21898,9 +21969,8 @@ package body Sem_Prag is loop Def_Id := Get_Base_Subprogram (E); - if not Ekind_In (Def_Id, E_Function, - E_Generic_Function, - E_Operator) + if Ekind (Def_Id) not in + E_Function | E_Generic_Function | E_Operator then Error_Pragma_Arg ("pragma% requires a function name", Arg1); @@ -22435,8 +22505,8 @@ package body Sem_Prag is Mark_Ghost_Pragma (N, Cunit_Ent); - if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, - N_Generic_Package_Declaration) + if Nkind (Unit (Cunit_Node)) not in + N_Package_Declaration | N_Generic_Package_Declaration then Error_Pragma ("pragma% can only apply to a package declaration"); @@ -22635,8 +22705,8 @@ package body Sem_Prag is Mark_Ghost_Pragma (N, Cunit_Ent); - if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, - N_Generic_Package_Declaration) + if Nkind (Unit (Cunit_Node)) not in + N_Package_Declaration | N_Generic_Package_Declaration then Error_Pragma ("pragma% can only apply to a package declaration"); @@ -22938,7 +23008,7 @@ package body Sem_Prag is -- anonymous type whose name cannot be used to issue error -- messages. Recover the original entity of the type. - if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then + if Ekind (Entity) in E_Protected_Type | E_Task_Type then Err_Id := Defining_Entity (Original_Node (Unit_Declaration_Node (Entity))); @@ -23000,28 +23070,28 @@ package body Sem_Prag is procedure Add_Entity_To_Name_Buffer is begin - if Ekind_In (E, E_Entry, E_Entry_Family) then + if Ekind (E) in E_Entry | E_Entry_Family then Add_Str_To_Name_Buffer ("entry"); - elsif Ekind_In (E, E_Generic_Package, - E_Package, - E_Package_Body) + elsif Ekind (E) in E_Generic_Package + | E_Package + | E_Package_Body then Add_Str_To_Name_Buffer ("package"); - elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then + elsif Ekind (E) in E_Protected_Body | E_Protected_Type then Add_Str_To_Name_Buffer ("protected type"); - elsif Ekind_In (E, E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Procedure, - E_Subprogram_Body) + elsif Ekind (E) in E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Procedure + | E_Subprogram_Body then Add_Str_To_Name_Buffer ("subprogram"); else - pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type)); + pragma Assert (Ekind (E) in E_Task_Body | E_Task_Type); Add_Str_To_Name_Buffer ("task type"); end if; end Add_Entity_To_Name_Buffer; @@ -23080,7 +23150,7 @@ package body Sem_Prag is -- * The mode of the context -- * The mode of the spec (if any) - if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then + if Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then -- A stand-alone subprogram body @@ -23130,7 +23200,7 @@ package body Sem_Prag is else pragma Assert - (Nkind_In (Decl, N_Protected_Body, N_Task_Body)); + (Nkind (Decl) in N_Protected_Body | N_Task_Body); Check_Pragma_Conformance (Context_Pragma => SPARK_Pragma (Body_Id), @@ -23252,8 +23322,8 @@ package body Sem_Prag is -- SPARK_Mode of the context because the task does not have any -- entries that could inherit the mode. - if not Nkind_In (Decl, N_Single_Task_Declaration, - N_Task_Type_Declaration) + if Nkind (Decl) not in + N_Single_Task_Declaration | N_Task_Type_Declaration then Set_SPARK_Context; end if; @@ -23414,8 +23484,8 @@ package body Sem_Prag is -- procedure Proc ...; -- pragma SPARK_Mode ...; - elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) + elsif Nkind (Stmt) in N_Generic_Subprogram_Declaration + | N_Subprogram_Declaration or else (Nkind (Stmt) = N_Entry_Declaration and then Is_Protected_Type (Scope (Defining_Entity (Stmt)))) @@ -23460,11 +23530,11 @@ package body Sem_Prag is -- protected body Prot is -- pragma SPARK_Mode ...; - if Nkind_In (Context, N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + if Nkind (Context) in N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body then Process_Body (Context); @@ -23481,9 +23551,9 @@ package body Sem_Prag is -- private -- pragma SPARK_Mode ...; - elsif Nkind_In (Context, N_Package_Specification, - N_Protected_Definition, - N_Task_Definition) + elsif Nkind (Context) in N_Package_Specification + | N_Protected_Definition + | N_Task_Definition then if List_Containing (N) = Visible_Declarations (Context) then Process_Visible_Part (Parent (Context)); @@ -23509,8 +23579,8 @@ package body Sem_Prag is -- procedure Proc ...; -- pragma SPARK_Mode ...; - elsif Nkind_In (Context, N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) + elsif Nkind (Context) in N_Generic_Subprogram_Declaration + | N_Subprogram_Declaration then Process_Overloadable (Context); @@ -24271,8 +24341,8 @@ package body Sem_Prag is -- in a library-level package. First determine whether the current -- compilation unit is a legal context. - if Nkind_In (Pack_Decl, N_Package_Declaration, - N_Generic_Package_Declaration) + if Nkind (Pack_Decl) in N_Package_Declaration + | N_Generic_Package_Declaration then null; @@ -24308,11 +24378,11 @@ package body Sem_Prag is -- The context is a [generic] subprogram declared at the top level -- of the [generic] package unit. - elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) + elsif Nkind (Subp_Decl) in N_Generic_Subprogram_Declaration + | N_Subprogram_Declaration and then Present (Context) - and then Nkind_In (Context, N_Generic_Package_Declaration, - N_Package_Declaration) + and then Nkind (Context) in N_Generic_Package_Declaration + | N_Package_Declaration then null; @@ -24366,9 +24436,9 @@ package body Sem_Prag is -- or subprogram body because it cannot benefit from forward -- references. - if Nkind_In (Subp_Decl, N_Entry_Body, - N_Subprogram_Body, - N_Subprogram_Body_Stub) + if Nkind (Subp_Decl) in N_Entry_Body + | N_Subprogram_Body + | N_Subprogram_Body_Stub then -- The legality checks of pragma Test_Case are affected by the -- SPARK mode in effect and the volatility of the context. @@ -25031,7 +25101,7 @@ package body Sem_Prag is Spec_Id := Unique_Defining_Entity (Subp_Decl); - if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then + if Ekind (Spec_Id) not in E_Function | E_Generic_Function then Pragma_Misplaced; return; end if; @@ -25192,7 +25262,7 @@ package body Sem_Prag is -- was given otherwise, by shifting the arguments. if Nkind (Argx) = N_Identifier - and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove) + and then Chars (Argx) in Name_Gnat | Name_Gnatprove then if Chars (Argx) = Name_Gnat then if CodePeer_Mode or GNATprove_Mode then @@ -25245,7 +25315,7 @@ package body Sem_Prag is -- On/Off one argument case was processed by parser if Nkind (Argx) = N_Identifier - and then Nam_In (Chars (Argx), Name_On, Name_Off) + and then Chars (Argx) in Name_On | Name_Off then null; @@ -25617,7 +25687,7 @@ package body Sem_Prag is and then (Etype (Nod) = Disp_Typ or else Etype (Nod) = Class_Wide_Type (Disp_Typ)) - and then Ekind_In (Entity (Nod), E_Constant, E_Variable) + and then Ekind (Entity (Nod)) in E_Constant | E_Variable then Error_Msg_NE ("object in class-wide condition must be formal of type &", @@ -25995,9 +26065,8 @@ package body Sem_Prag is if Is_Entity_Name (Ref_Item) then Ref_Item_Id := Entity_Of (Ref_Item); - if Ekind_In (Ref_Item_Id, E_Abstract_State, - E_Constant, - E_Variable) + if Ekind (Ref_Item_Id) in + E_Abstract_State | E_Constant | E_Variable and then Present (Encapsulating_State (Ref_Item_Id)) and then Find_Encapsulating_State (Dep_States, Ref_Item_Id) = Dep_Item_Id @@ -26634,9 +26703,8 @@ package body Sem_Prag is -- The input must be a constituent of a state - if Ekind_In (Input_Id, E_Abstract_State, - E_Constant, - E_Variable) + if Ekind (Input_Id) in + E_Abstract_State | E_Constant | E_Variable and then Present (Encapsulating_State (Input_Id)) then State_Id := Encapsulating_State (Input_Id); @@ -27544,9 +27612,7 @@ package body Sem_Prag is -- Start of processing for Check_Refined_Global_Item begin - if Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Variable) + if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable then Enc_State := Find_Encapsulating_State (States, Item_Id); end if; @@ -27640,9 +27706,9 @@ package body Sem_Prag is -- Single global item declaration - elsif Nkind_In (List, N_Expanded_Name, - N_Identifier, - N_Selected_Component) + elsif Nkind (List) in N_Expanded_Name + | N_Identifier + | N_Selected_Component then Check_Refined_Global_Item (List, Global_Mode); @@ -27772,9 +27838,9 @@ package body Sem_Prag is -- Single global item declaration - elsif Nkind_In (List, N_Expanded_Name, - N_Identifier, - N_Selected_Component) + elsif Nkind (List) in N_Expanded_Name + | N_Identifier + | N_Selected_Component then Collect_Global_Item (List, Mode); @@ -28461,9 +28527,8 @@ package body Sem_Prag is -- The constituent is a valid state or object - elsif Ekind_In (Constit_Id, E_Abstract_State, - E_Constant, - E_Variable) + elsif Ekind (Constit_Id) in + E_Abstract_State | E_Constant | E_Variable then Match_Constituent (Constit_Id); @@ -29152,11 +29217,11 @@ package body Sem_Prag is if Ename = Pnm or else Pnm = Name_Assertion or else (Pnm = Name_Statement_Assertions - and then Nam_In (Ename, Name_Assert, - Name_Assert_And_Cut, - Name_Assume, - Name_Loop_Invariant, - Name_Loop_Variant)) + and then Ename in Name_Assert + | Name_Assert_And_Cut + | Name_Assume + | Name_Loop_Invariant + | Name_Loop_Variant) then Policy := Chars (Get_Pragma_Arg (Last (PPA))); @@ -29291,11 +29356,11 @@ package body Sem_Prag is or else (Pnm = Name_Assertion and then Is_Valid_Assertion_Kind (Nam)) or else (Pnm = Name_Statement_Assertions - and then Nam_In (Nam, Name_Assert, - Name_Assert_And_Cut, - Name_Assume, - Name_Loop_Invariant, - Name_Loop_Variant)) + and then Nam in Name_Assert + | Name_Assert_And_Cut + | Name_Assume + | Name_Loop_Invariant + | Name_Loop_Variant) then case (Chars (Get_Pragma_Arg (Last (PPA)))) is when Name_Check @@ -29375,7 +29440,7 @@ package body Sem_Prag is -- they depend on variable input. This check is left to the SPARK -- prover. - elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + elsif Ekind (Item_Id) in E_Abstract_State | E_Variable then return True; -- Recursively peek into nested packages and instantiations @@ -29612,8 +29677,8 @@ package body Sem_Prag is Prag := Pre_Post_Conditions (Prags); while Present (Prag) loop - if Nam_In (Pragma_Name_Unmapped (Prag), - Name_Precondition, Name_Postcondition) + if Pragma_Name_Unmapped (Prag) + in Name_Precondition | Name_Postcondition and then Class_Present (Prag) then -- The generated pragma must be analyzed in the context of @@ -29766,11 +29831,11 @@ package body Sem_Prag is procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is begin - if Nam_In (Mode, Name_In_Out, Name_Input) then + if Mode in Name_In_Out | Name_Input then Append_New_Elmt (Item, Subp_Inputs); end if; - if Nam_In (Mode, Name_In_Out, Name_Output) then + if Mode in Name_In_Out | Name_Output then Append_New_Elmt (Item, Subp_Outputs); end if; end Collect_Global_Item; @@ -29788,9 +29853,9 @@ package body Sem_Prag is -- Single global item declaration - elsif Nkind_In (List, N_Expanded_Name, - N_Identifier, - N_Selected_Component) + elsif Nkind (List) in N_Expanded_Name + | N_Identifier + | N_Selected_Component then Collect_Global_Item (List, Mode); @@ -29842,13 +29907,13 @@ package body Sem_Prag is -- Process all formal parameters of entries, [generic] subprograms, and -- their bodies. - if Ekind_In (Subp_Id, E_Entry, - E_Entry_Family, - E_Function, - E_Generic_Function, - E_Generic_Procedure, - E_Procedure, - E_Subprogram_Body) + if Ekind (Subp_Id) in E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Procedure + | E_Subprogram_Body then Subp_Decl := Unit_Declaration_Node (Subp_Id); Spec_Id := Unique_Defining_Entity (Subp_Decl); @@ -29857,11 +29922,11 @@ package body Sem_Prag is Formal := First_Entity (Spec_Id); while Present (Formal) loop - if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then + if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then Append_New_Elmt (Formal, Subp_Inputs); end if; - if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then + if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then Append_New_Elmt (Formal, Subp_Outputs); -- Out parameters can act as inputs when the related type is @@ -29881,7 +29946,7 @@ package body Sem_Prag is -- Otherwise the input denotes a task type, a task body, or the -- anonymous object created for a single task type. - elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body) + elsif Ekind (Subp_Id) in E_Task_Type | E_Task_Body or else Is_Single_Task_Object (Subp_Id) then Subp_Decl := Declaration_Node (Subp_Id); @@ -29893,7 +29958,7 @@ package body Sem_Prag is -- outputs. if Is_Entry_Body (Subp_Id) - or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body) + or else Ekind (Subp_Id) in E_Subprogram_Body | E_Task_Body then Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends); Global := Get_Pragma (Subp_Id, Pragma_Refined_Global); @@ -29951,7 +30016,7 @@ package body Sem_Prag is Append_New_Elmt (Typ, Subp_Inputs); - if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then + if Ekind (Spec_Id) in E_Entry | E_Entry_Family | E_Procedure then Append_New_Elmt (Typ, Subp_Outputs); end if; @@ -30000,8 +30065,8 @@ package body Sem_Prag is function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is begin - return Nam_In (Pragma_Name_Unmapped (N), - Name_Interrupt_State, Name_Priority_Specific_Dispatching); + return Pragma_Name_Unmapped (N) + in Name_Interrupt_State | Name_Priority_Specific_Dispatching; end Delay_Config_Pragma_Analyze; ----------------------- @@ -30158,10 +30223,10 @@ package body Sem_Prag is Stmt : Node_Id; Look_For_Body : constant Boolean := - Nam_In (Prag_Nam, Name_Refined_Depends, - Name_Refined_Global, - Name_Refined_Post, - Name_Refined_State); + Prag_Nam in Name_Refined_Depends + | Name_Refined_Global + | Name_Refined_Post + | Name_Refined_State; -- Refinement pragmas must be associated with a subprogram body [stub] -- Start of processing for Find_Related_Declaration_Or_Body @@ -30745,6 +30810,8 @@ package body Sem_Prag is Pragma_C_Pass_By_Copy => 0, Pragma_Comment => -1, Pragma_Common_Object => 0, + Pragma_CUDA_Execute => -1, + Pragma_CUDA_Global => -1, Pragma_Compile_Time_Error => -1, Pragma_Compile_Time_Warning => -1, Pragma_Compiler_Unit => -1, @@ -31906,10 +31973,8 @@ package body Sem_Prag is Args : Node_Id; begin - pragma Assert (Nam_In (Arg_Nam, Name_Ensures, - Name_Mode, - Name_Name, - Name_Requires)); + pragma Assert + (Arg_Nam in Name_Ensures | Name_Mode | Name_Name | Name_Requires); -- The caller requests the aspect argument diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index bdc4495..460fc9c 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -49,6 +49,7 @@ package Sem_Prag is Pragma_Contract_Cases => True, Pragma_Convention => True, Pragma_CPU => True, + Pragma_CUDA_Global => True, Pragma_Default_Initial_Condition => True, Pragma_Default_Storage_Pool => True, Pragma_Depends => True, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index bea7a57..50a4287 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -455,8 +455,8 @@ package body Sem_Res is and then not (Nkind (Parent (P)) = N_Subtype_Indication and then - Nkind_In (Parent (Parent (P)), N_Component_Definition, - N_Subtype_Declaration) + Nkind (Parent (Parent (P))) in N_Component_Definition + | N_Subtype_Declaration and then Paren_Count (N) = 0) then Error_Msg_N @@ -580,8 +580,8 @@ package body Sem_Res is -- Legal case is in index or discriminant constraint - elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, - N_Discriminant_Association) + elsif Nkind (PN) in N_Index_Or_Discriminant_Constraint + | N_Discriminant_Association then if Paren_Count (N) > 0 then Error_Msg_N @@ -602,9 +602,8 @@ package body Sem_Res is else D := PN; P := Parent (PN); - while not Nkind_In (P, N_Component_Declaration, - N_Subtype_Indication, - N_Entry_Declaration) + while Nkind (P) not in + N_Component_Declaration | N_Subtype_Indication | N_Entry_Declaration loop D := P; P := Parent (P); @@ -617,8 +616,8 @@ package body Sem_Res is -- course a double fault. if (Nkind (P) = N_Subtype_Indication - and then Nkind_In (Parent (P), N_Component_Definition, - N_Derived_Type_Definition) + and then Nkind (Parent (P)) in N_Component_Definition + | N_Derived_Type_Definition and then D = Constraint (P)) -- The constraint itself may be given by a subtype indication, @@ -810,12 +809,12 @@ package body Sem_Res is function Is_Conditional_Statement (N : Node_Id) return Boolean is begin return - Nkind_In (N, N_And_Then, - N_Case_Expression, - N_Case_Statement, - N_If_Expression, - N_If_Statement, - N_Or_Else); + Nkind (N) in N_And_Then + | N_Case_Expression + | N_Case_Statement + | N_If_Expression + | N_If_Statement + | N_Or_Else; end Is_Conditional_Statement; ------------------------------- @@ -841,7 +840,7 @@ package body Sem_Res is begin return Nkind (HSS) = N_Handled_Sequence_Of_Statements - and then Nkind_In (Parent (HSS), N_Entry_Body, N_Subprogram_Body) + and then Nkind (Parent (HSS)) in N_Entry_Body | N_Subprogram_Body and then Is_List_Member (N) and then List_Containing (N) = Statements (HSS); end Is_Immediately_Within_Body; @@ -1149,9 +1148,8 @@ package body Sem_Res is -- functions, this is never a parameterless call (RM 4.1.4(6)). if Nkind (Parent (N)) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Parent (N)), Name_Address, - Name_Code_Address, - Name_Access) + and then Attribute_Name (Parent (N)) + in Name_Address | Name_Code_Address | Name_Access then return False; end if; @@ -1201,9 +1199,9 @@ package body Sem_Res is and then Ekind (Entity (N)) = E_Procedure and then not Is_Overloaded (N) and then - Nkind_In (Parent (N), N_Parameter_Association, - N_Function_Call, - N_Procedure_Call_Statement) + Nkind (Parent (N)) in N_Parameter_Association + | N_Function_Call + | N_Procedure_Call_Statement then return; end if; @@ -1238,8 +1236,8 @@ package body Sem_Res is (Nkind (N) = N_Selected_Component and then (Ekind (Entity (Selector_Name (N))) = E_Function or else - (Ekind_In (Entity (Selector_Name (N)), E_Entry, - E_Procedure) + (Ekind (Entity (Selector_Name (N))) in + E_Entry | E_Procedure and then Is_Overloaded (Selector_Name (N))))) -- If one of the above three conditions is met, rewrite as call. Apply @@ -1547,7 +1545,7 @@ package body Sem_Res is elsif In_Instance then null; - elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) + elsif Op_Name in Name_Op_Multiply | Name_Op_Divide and then Is_Fixed_Point_Type (Etype (Act1)) and then Is_Fixed_Point_Type (Etype (Act2)) then @@ -1559,7 +1557,7 @@ package body Sem_Res is -- available. elsif Ada_Version >= Ada_2005 - and then Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) + and then Op_Name in Name_Op_Eq | Name_Op_Ne and then (Is_Anonymous_Access_Type (Etype (Act1)) or else Is_Anonymous_Access_Type (Etype (Act2))) then @@ -1670,7 +1668,7 @@ package body Sem_Res is and then not In_Instance then if Is_Fixed_Point_Type (Typ) - and then Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) + and then Op_Name in Name_Op_Multiply | Name_Op_Divide then -- Already checked above @@ -1707,7 +1705,7 @@ package body Sem_Res is -- the equality node will not resolve any remaining ambiguity, and it -- assumes that the first operand is not overloaded. - if Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) + if Op_Name in Name_Op_Eq | Name_Op_Ne and then Ekind (Func) = E_Function and then Is_Overloaded (Act1) then @@ -2162,9 +2160,9 @@ package body Sem_Res is -- access-to-subprogram type. if Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Access, - Name_Unrestricted_Access, - Name_Unchecked_Access) + and then Attribute_Name (N) in Name_Access + | Name_Unrestricted_Access + | Name_Unchecked_Access and then Comes_From_Source (N) and then Is_Entity_Name (Prefix (N)) and then Is_Subprogram (Entity (Prefix (N))) @@ -2582,10 +2580,10 @@ package body Sem_Res is Set_Entity (N, Seen); Generate_Reference (Seen, N); - elsif Nkind_In (N, N_Case_Expression, - N_Character_Literal, - N_Delta_Aggregate, - N_If_Expression) + elsif Nkind (N) in N_Case_Expression + | N_Character_Literal + | N_Delta_Aggregate + | N_If_Expression then Set_Etype (N, Expr_Type); @@ -2651,15 +2649,15 @@ package body Sem_Res is -- with a name that is an explicit dereference, there is -- nothing to be done at this point. - elsif Nkind_In (N, N_Attribute_Reference, - N_And_Then, - N_Explicit_Dereference, - N_Identifier, - N_Indexed_Component, - N_Or_Else, - N_Range, - N_Selected_Component, - N_Slice) + elsif Nkind (N) in N_Attribute_Reference + | N_And_Then + | N_Explicit_Dereference + | N_Identifier + | N_Indexed_Component + | N_Or_Else + | N_Range + | N_Selected_Component + | N_Slice or else Nkind (Name (N)) = N_Explicit_Dereference then null; @@ -3035,7 +3033,7 @@ package body Sem_Res is Resolution_Failed; return; - -- Only one intepretation + -- Only one interpretation else -- In Ada 2005, if we have something like "X : T := 2 + 2;", where @@ -4114,27 +4112,33 @@ package body Sem_Res is then declare Expr_Typ : constant Entity_Id := Etype (Expression (A)); + begin - if Ekind (F) = E_In_Out_Parameter - and then Is_Array_Type (Etype (F)) + -- Check RM 4.6 (24.2/2) + + if Is_Array_Type (Etype (F)) + and then Is_View_Conversion (A) then -- In a view conversion, the conversion must be legal in -- both directions, and thus both component types must be -- aliased, or neither (4.6 (8)). - -- The extra rule in 4.6 (24.9.2) seems unduly - -- restrictive: the privacy requirement should not apply - -- to generic types, and should be checked in an - -- instance. ARG query is in order ??? + -- Check RM 4.6 (24.8/2) if Has_Aliased_Components (Expr_Typ) /= Has_Aliased_Components (Etype (F)) then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); + -- This normally illegal conversion is legal in an + -- expanded instance body because of RM 12.3(11). + -- At runtime, conversion must create a new object. + + if not In_Instance then + Error_Msg_N + ("both component types in a view conversion must" + & " be aliased, or neither", A); + end if; - -- Comment here??? what set of cases??? + -- Check RM 4.6 (24/3) elsif not Same_Ancestor (Etype (F), Expr_Typ) then -- Check view conv between unrelated by ref array @@ -4177,27 +4181,34 @@ package body Sem_Res is end if; end if; - -- AI12-0074 + -- AI12-0074 & AI12-0377 -- Check 6.4.1: If the mode is out, the actual parameter is -- a view conversion, and the type of the formal parameter - -- is a scalar type that has the Default_Value aspect - -- specified, then - -- - there shall exist a type (other than a root numeric - -- type) that is an ancestor of both the target type and - -- the operand type; and - -- - the type of the operand of the conversion shall have - -- the Default_Value aspect specified. + -- is a scalar type, then either: + -- - the target and operand type both do not have the + -- Default_Value aspect specified; or + -- - the target and operand type both have the + -- Default_Value aspect specified, and there shall exist + -- a type (other than a root numeric type) that is an + -- ancestor of both the target type and the operand + -- type. elsif Ekind (F) = E_Out_Parameter and then Is_Scalar_Type (Etype (F)) - and then Present (Default_Aspect_Value (Etype (F))) - and then - (not Same_Ancestor (Etype (F), Expr_Typ) - or else No (Default_Aspect_Value (Expr_Typ))) then - Error_Msg_N - ("view conversion between unrelated types with " - & "Default_Value not allowed (RM 6.4.1)", A); + if Has_Default_Aspect (Etype (F)) /= + Has_Default_Aspect (Expr_Typ) + then + Error_Msg_N + ("view conversion requires Default_Value on both " & + "types (RM 6.4.1)", A); + elsif Has_Default_Aspect (Expr_Typ) + and then not Same_Ancestor (Etype (F), Expr_Typ) + then + Error_Msg_N + ("view conversion between unrelated types with " + & "Default_Value not allowed (RM 6.4.1)", A); + end if; end if; end; @@ -4546,7 +4557,7 @@ package body Sem_Res is -- Apply appropriate constraint/predicate checks for IN [OUT] case - if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then + if Ekind (F) in E_In_Parameter | E_In_Out_Parameter then -- Apply predicate tests except in certain special cases. Note -- that it might be more consistent to apply these only when @@ -4628,7 +4639,7 @@ package body Sem_Res is -- Checks for OUT parameters and IN OUT parameters - if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then + if Ekind (F) in E_Out_Parameter | E_In_Out_Parameter then -- If there is a type conversion, make sure the return value -- meets the constraints of the variable before the conversion. @@ -4947,7 +4958,7 @@ package body Sem_Res is if Comes_From_Source (Nam) and then Is_Ghost_Entity (Nam) - and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter) + and then Ekind (F) in E_In_Out_Parameter | E_Out_Parameter and then Is_Entity_Name (A) and then Present (Entity (A)) and then not Is_Ghost_Entity (Entity (A)) @@ -5234,7 +5245,7 @@ package body Sem_Res is Aggr := Original_Node (Expression (E)); if Has_Discriminants (Subtyp) - and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) + and then Nkind (Aggr) in N_Aggregate | N_Extension_Aggregate then Discrim := First_Discriminant (Base_Type (Subtyp)); @@ -5591,18 +5602,18 @@ package body Sem_Res is -- N is the expression after "delta" in a fixed_point_definition; -- see RM-3.5.9(6): - return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, - N_Decimal_Fixed_Point_Definition, + return Nkind (Parent (N)) in N_Ordinary_Fixed_Point_Definition + | N_Decimal_Fixed_Point_Definition -- N is one of the bounds in a real_range_specification; -- see RM-3.5.7(5): - N_Real_Range_Specification, + | N_Real_Range_Specification -- N is the expression of a delta_constraint; -- see RM-J.3(3): - N_Delta_Constraint); + | N_Delta_Constraint; end Expected_Type_Is_Any_Real; ----------------------------- @@ -5684,7 +5695,7 @@ package body Sem_Res is -- a conversion will be applied to each operand, so resolve it -- with its own type. - if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then + if Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply then Resolve (N); else @@ -5772,7 +5783,7 @@ package body Sem_Res is -- involving a fixed-point operand) the conditional expression must -- resolve to a unique visible fixed_point type, normally Duration. - elsif Nkind_In (N, N_Case_Expression, N_If_Expression) + elsif Nkind (N) in N_Case_Expression | N_If_Expression and then Etype (N) = Universal_Real and then Is_Fixed_Point_Type (B_Typ) then @@ -5837,7 +5848,7 @@ package body Sem_Res is and then (Is_Integer_Or_Universal (L) or else Is_Integer_Or_Universal (R)))) - and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) + and then Nkind (N) in N_Op_Multiply | N_Op_Divide then if TL = Universal_Integer or else TR = Universal_Integer then Check_For_Visible_Operator (N, B_Typ); @@ -5883,8 +5894,8 @@ package body Sem_Res is then if B_Typ = Universal_Fixed and then not Expected_Type_Is_Any_Real (N) - and then not Nkind_In (Parent (N), N_Type_Conversion, - N_Unchecked_Type_Conversion) + and then Nkind (Parent (N)) not in + N_Type_Conversion | N_Unchecked_Type_Conversion then Error_Msg_N ("type cannot be determined from context!", N); Error_Msg_N ("\explicit conversion to result type required", N); @@ -5895,9 +5906,8 @@ package body Sem_Res is else if Ada_Version = Ada_83 and then Etype (N) = Universal_Fixed - and then not - Nkind_In (Parent (N), N_Type_Conversion, - N_Unchecked_Type_Conversion) + and then Nkind (Parent (N)) not in + N_Type_Conversion | N_Unchecked_Type_Conversion then Error_Msg_N ("(Ada 83) fixed-point operation needs explicit " @@ -5985,7 +5995,7 @@ package body Sem_Res is -- Give warning if explicit division by zero - if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) + if Nkind (N) in N_Op_Divide | N_Op_Rem | N_Op_Mod and then not Division_Checks_Suppressed (Etype (N)) then Rop := Right_Opnd (N); @@ -6066,7 +6076,7 @@ package body Sem_Res is -- if both operands can be negative. if Restriction_Check_Required (No_Implicit_Conditionals) - and then Nkind_In (N, N_Op_Rem, N_Op_Mod) + and then Nkind (N) in N_Op_Rem | N_Op_Mod then declare Lo : Uint; @@ -6216,7 +6226,7 @@ package body Sem_Res is -- operations use the same circuitry because the name in the call -- can be an arbitrary expression with special resolution rules. - elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) + elsif Nkind (Subp) in N_Selected_Component | N_Indexed_Component or else (Is_Entity_Name (Subp) and then Is_Entry (Entity (Subp))) then Resolve_Entry_Call (N, Typ); @@ -6573,7 +6583,7 @@ package body Sem_Res is if Same_Or_Aliased_Subprograms (Nam, Scop) and then not Restriction_Active (No_Recursion) - and then not Is_Static_Expression_Function (Scop) + and then not Is_Static_Function (Scop) and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do @@ -6591,11 +6601,10 @@ package body Sem_Res is Scope_Loop : while Scop /= Standard_Standard loop if Same_Or_Aliased_Subprograms (Nam, Scop) then - -- Ada 202x (AI12-0075): Static expression function are - -- never allowed to make a recursive call, as specified - -- by 6.8(5.4/5). + -- Ada 202x (AI12-0075): Static functions are never allowed + -- to make a recursive call, as specified by 6.8(5.4/5). - if Is_Static_Expression_Function (Scop) then + if Is_Static_Function (Scop) then Error_Msg_N ("recursive call not allowed in static expression " & "function", N); @@ -6648,8 +6657,8 @@ package body Sem_Res is begin P := Prev (N); while Present (P) loop - if not Nkind_In (P, N_Assignment_Statement, - N_Raise_Constraint_Error) + if Nkind (P) not in N_Assignment_Statement + | N_Raise_Constraint_Error then exit Scope_Loop; end if; @@ -6758,7 +6767,7 @@ package body Sem_Res is or else Is_Build_In_Place_Function (Nam) or else Is_Intrinsic_Subprogram (Nam) or else Is_Inlinable_Expression_Function (Nam) - or else Is_Static_Expression_Function_Call (N) + or else Is_Static_Function_Call (N) then null; @@ -6766,7 +6775,7 @@ package body Sem_Res is -- secondary stack (or any other one). elsif Expander_Active - and then Ekind_In (Nam, E_Function, E_Subprogram_Type) + and then Ekind (Nam) in E_Function | E_Subprogram_Type and then Requires_Transient_Scope (Etype (Nam)) and then not Is_Ignored_Ghost_Entity (Nam) then @@ -6865,7 +6874,7 @@ package body Sem_Res is F := First_Formal (Nam); A := First_Actual (N); while Present (F) and then Present (A) loop - if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) + if Ekind (F) in E_Out_Parameter | E_In_Out_Parameter and then Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) @@ -7032,10 +7041,10 @@ package body Sem_Res is -- when doing the inlining). if not Checking_Potentially_Static_Expression - and then Is_Static_Expression_Function_Call (N) + and then Is_Static_Function_Call (N) and then not Error_Posted (Ultimate_Alias (Nam)) then - Inline_Static_Expression_Function_Call (N, Ultimate_Alias (Nam)); + Inline_Static_Function_Call (N, Ultimate_Alias (Nam)); -- In GNATprove mode, expansion is disabled, but we want to inline some -- subprograms to facilitate formal verification. Indirect calls through @@ -7580,8 +7589,8 @@ package body Sem_Res is Expr : Node_Id) return Boolean is begin - if Nkind_In (Context, N_Assignment_Statement, - N_Object_Declaration) + if Nkind (Context) in + N_Assignment_Statement | N_Object_Declaration and then Expression (Context) = Expr then return True; @@ -7589,15 +7598,15 @@ package body Sem_Res is -- Check whether a construct that yields a name is the expression of -- an assignment statement or an object declaration. - elsif (Nkind_In (Context, N_Attribute_Reference, - N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) + elsif (Nkind (Context) in N_Attribute_Reference + | N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + | N_Slice and then Prefix (Context) = Expr) or else - (Nkind_In (Context, N_Type_Conversion, - N_Unchecked_Type_Conversion) + (Nkind (Context) in N_Type_Conversion + | N_Unchecked_Type_Conversion and then Expression (Context) = Expr) then return @@ -8461,13 +8470,11 @@ package body Sem_Res is S : Entity_Id; begin - if Ekind_In (Etype (R), E_Allocator_Type, - E_Access_Attribute_Type) + if Ekind (Etype (R)) in E_Allocator_Type | E_Access_Attribute_Type then Acc := Designated_Type (Etype (R)); - elsif Ekind_In (Etype (L), E_Allocator_Type, - E_Access_Attribute_Type) + elsif Ekind (Etype (L)) in E_Allocator_Type | E_Access_Attribute_Type then Acc := Designated_Type (Etype (L)); else @@ -8520,7 +8527,7 @@ package body Sem_Res is return; elsif T = Any_Access - or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type) + or else Ekind (T) in E_Allocator_Type | E_Access_Attribute_Type then T := Find_Unique_Access_Type; @@ -8661,8 +8668,8 @@ package body Sem_Res is if Expander_Active and then - (Ekind_In (T, E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + (Ekind (T) in E_Anonymous_Access_Type + | E_Anonymous_Access_Subprogram_Type or else Is_Private_Type (T)) then if Etype (L) /= T then @@ -9156,7 +9163,7 @@ package body Sem_Res is Array_Type := Implicitly_Designated_Type (Array_Type); end if; - -- If name was overloaded, set component type correctly now + -- If name was overloaded, set component type correctly now. -- If a misplaced call to an entry family (which has no index types) -- return. Error will be diagnosed from calling context. @@ -9259,7 +9266,7 @@ package body Sem_Res is Res : Node_Id; begin - if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then + if Nkind (Opnd) in N_Integer_Literal | N_Real_Literal then Res := Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (Btyp, Loc), @@ -9452,7 +9459,7 @@ package body Sem_Res is if Short_Circuit_And_Or and then B_Typ = Standard_Boolean - and then Nkind_In (N, N_Op_And, N_Op_Or) + and then Nkind (N) in N_Op_And | N_Op_Or then -- Mark the corresponding putative SCO operator as truly a logical -- (and short-circuit) operator. @@ -9585,9 +9592,9 @@ package body Sem_Res is Alt := First (Alternatives (N)); while Present (Alt) loop if Is_OK_Static_Expression (Alt) - and then (Nkind_In (Alt, N_Integer_Literal, - N_Character_Literal) - or else Nkind (Alt) in N_Has_Entity) + and then Nkind (Alt) in N_Integer_Literal + | N_Character_Literal + | N_Has_Entity then Nalts := Nalts + 1; Alts (Nalts) := (Alt, Expr_Value (Alt)); @@ -10240,7 +10247,7 @@ package body Sem_Res is begin if B_Typ = Standard_Boolean - and then Nkind_In (Opnd, N_Op_Eq, N_Op_Ne) + and then Nkind (Opnd) in N_Op_Eq | N_Op_Ne and then Is_Overloaded (Opnd) then Resolve_Equality_Op (Opnd, B_Typ); @@ -11258,10 +11265,10 @@ package body Sem_Res is elsif Nkind (Parent (N)) = N_Op_Concat and then not Need_Check - and then not Nkind_In (Original_Node (N), N_Character_Literal, - N_Attribute_Reference, - N_Qualified_Expression, - N_Type_Conversion) + and then Nkind (Original_Node (N)) not in N_Character_Literal + | N_Attribute_Reference + | N_Qualified_Expression + | N_Type_Conversion then Subtype_Id := Typ; @@ -11547,14 +11554,14 @@ package body Sem_Res is -- precision. if Is_Fixed_Point_Type (Typ) - and then Nkind_In (Operand, N_Op_Divide, N_Op_Multiply) + and then Nkind (Operand) in N_Op_Divide | N_Op_Multiply and then Etype (Left_Opnd (Operand)) = Any_Fixed and then Etype (Right_Opnd (Operand)) = Any_Fixed then Set_Etype (Operand, Universal_Real); elsif Is_Numeric_Type (Typ) - and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) + and then Nkind (Operand) in N_Op_Multiply | N_Op_Divide and then (Etype (Right_Opnd (Operand)) = Universal_Real or else Etype (Left_Opnd (Operand)) = Universal_Real) @@ -11680,6 +11687,7 @@ package body Sem_Res is -- odd subtype coming from the bounds). if (Is_Entity_Name (Orig_N) + and then Present (Entity (Orig_N)) and then (Etype (Entity (Orig_N)) = Orig_T or else @@ -11715,11 +11723,11 @@ package body Sem_Res is -- newer language version. elsif Nkind (Orig_N) = N_Qualified_Expression - and then Nkind_In (Parent (N), N_Attribute_Reference, - N_Indexed_Component, - N_Selected_Component, - N_Slice, - N_Explicit_Dereference) + and then Nkind (Parent (N)) in N_Attribute_Reference + | N_Indexed_Component + | N_Selected_Component + | N_Slice + | N_Explicit_Dereference then null; @@ -11734,17 +11742,15 @@ package body Sem_Res is -- entity, give the name of the entity in the message. If not, -- just mention the expression. - -- Shoudn't we test Warn_On_Redundant_Constructs here ??? - else if Is_Entity_Name (Orig_N) then Error_Msg_Node_2 := Orig_T; Error_Msg_NE -- CODEFIX - ("??redundant conversion, & is of type &!", + ("?r?redundant conversion, & is of type &!", N, Entity (Orig_N)); else Error_Msg_NE - ("??redundant conversion, expression is of type&!", + ("?r?redundant conversion, expression is of type&!", N, Orig_T); end if; end if; @@ -11851,7 +11857,7 @@ package body Sem_Res is -- Handle subtypes - if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then + if Ekind (Opnd) in E_Protected_Subtype | E_Task_Subtype then Opnd := Etype (Opnd); end if; @@ -12009,7 +12015,7 @@ package body Sem_Res is -- mod. These are the cases where the grouping can affect results. if Paren_Count (Rorig) = 0 - and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) + and then Nkind (Rorig) in N_Op_Mod | N_Op_Multiply | N_Op_Divide then -- For mod, we always give the warning, since the value is -- affected by the parenthesization (e.g. (-5) mod 315 /= @@ -12091,7 +12097,7 @@ package body Sem_Res is -- overflow is impossible (divisor > 1) or we have a case of -- division by zero in any case. - if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) + if Nkind (Rorig) in N_Op_Divide | N_Op_Rem and then Compile_Time_Known_Value (Right_Opnd (Rorig)) and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 then @@ -12569,9 +12575,9 @@ package body Sem_Res is or else (Is_Fixed_Point_Type (Target_Typ) and then Conversion_OK (N))) and then Nkind (Operand) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Operand), Name_Rounding, - Name_Machine_Rounding, - Name_Truncation) + and then Attribute_Name (Operand) in Name_Rounding + | Name_Machine_Rounding + | Name_Truncation then declare Truncate : constant Boolean := @@ -12704,7 +12710,7 @@ package body Sem_Res is -- When the context is a type conversion, issue the warning on the -- expression of the conversion because it is the actual operation. - if Nkind_In (N, N_Type_Conversion, N_Unchecked_Type_Conversion) then + if Nkind (N) in N_Type_Conversion | N_Unchecked_Type_Conversion then ErrN := Expression (N); else ErrN := N; @@ -12925,11 +12931,10 @@ package body Sem_Res is -- <prefix>.all.Access_Discrim.all.Access_Discrim case, -- where the correct result depends on <prefix>. - return Nkind_In (Associated_Node, - N_Procedure_Specification, -- access parameter - N_Function_Specification, -- access parameter - N_Object_Declaration -- saooaaat - ) + return Nkind (Associated_Node) in + N_Procedure_Specification | -- access parameter + N_Function_Specification | -- access parameter + N_Object_Declaration -- saooaaat or else Is_Discrim_Of_Bad_Access_Conversion_Argument (Deref_Prefix); end Is_Discrim_Of_Bad_Access_Conversion_Argument; @@ -13003,9 +13008,9 @@ package body Sem_Res is -- checks that must be applied to such conversions to prevent -- out-of-scope references. - elsif Ekind_In - (Target_Comp_Base, E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + elsif Ekind (Target_Comp_Base) in + E_Anonymous_Access_Type + | E_Anonymous_Access_Subprogram_Type and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) and then Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) @@ -13314,8 +13319,8 @@ package body Sem_Res is -- interface type. elsif Is_Access_Type (Opnd_Type) - and then Ekind_In (Target_Type, E_General_Access_Type, - E_Anonymous_Access_Type) + and then Ekind (Target_Type) in + E_General_Access_Type | E_Anonymous_Access_Type and then Is_Interface (Directly_Designated_Type (Target_Type)) then -- Check the static accessibility rule of 4.6(17). Note that the @@ -13395,7 +13400,7 @@ package body Sem_Res is if Is_Entity_Name (Operand) and then not Is_Local_Anonymous_Access (Opnd_Type) and then - Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) + Ekind (Entity (Operand)) in E_In_Parameter | E_Constant and then Present (Discriminal_Link (Entity (Operand))) then Conversion_Error_N @@ -13410,14 +13415,15 @@ package body Sem_Res is -- General and anonymous access types - elsif Ekind_In (Target_Type, E_General_Access_Type, - E_Anonymous_Access_Type) + elsif Ekind (Target_Type) in + E_General_Access_Type | E_Anonymous_Access_Type and then Conversion_Check (Is_Access_Type (Opnd_Type) - and then not - Ekind_In (Opnd_Type, E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type), + and then + Ekind (Opnd_Type) not in + E_Access_Subprogram_Type | + E_Access_Protected_Subprogram_Type, "must be an access-to-object type") then if Is_Access_Constant (Opnd_Type) @@ -13473,10 +13479,10 @@ package body Sem_Res is -- as universal_access "=". elsif not Is_Local_Anonymous_Access (Opnd_Type) - and then Nkind_In (Associated_Node_For_Itype (Opnd_Type), - N_Function_Specification, - N_Procedure_Specification) - and then not Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne) + and then Nkind (Associated_Node_For_Itype (Opnd_Type)) in + N_Function_Specification | + N_Procedure_Specification + and then Nkind (Parent (N)) not in N_Op_Eq | N_Op_Ne then Conversion_Error_N ("implicit conversion of anonymous access parameter " @@ -13590,7 +13596,7 @@ package body Sem_Res is if Is_Entity_Name (Operand) and then - Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) + Ekind (Entity (Operand)) in E_In_Parameter | E_Constant and then Present (Discriminal_Link (Entity (Operand))) then Conversion_Error_N diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index aa226ed..f8ad56b 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -86,8 +86,8 @@ package body Sem_SCIL is -- object or parameter declaration. Interface types are still -- unsupported. - elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, - N_Parameter_Specification) + elsif Nkind (Ctrl_Tag) in + N_Object_Declaration | N_Parameter_Specification then Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); @@ -132,10 +132,10 @@ package body Sem_SCIL is -- Check contents of the boolean expression associated with the -- membership test. - pragma Assert (Nkind_In (N, N_Identifier, - N_And_Then, - N_Or_Else, - N_Expression_With_Actions) + pragma Assert + (Nkind (N) in + N_Identifier | N_And_Then | N_Or_Else | + N_Expression_With_Actions and then Etype (N) = Standard_Boolean); -- Check the entity identifier of the associated tagged type (that diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index d975edc..a5e62a7 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1039,8 +1039,8 @@ package body Sem_Type is -- An Access_To_Subprogram is compatible with itself, or with an -- anonymous type created for an attribute reference Access. - elsif Ekind_In (BT1, E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type) + elsif Ekind (BT1) in E_Access_Subprogram_Type + | E_Access_Protected_Subprogram_Type and then Is_Access_Type (T2) and then (not Comes_From_Source (T1) or else not Comes_From_Source (T2)) @@ -1055,8 +1055,8 @@ package body Sem_Type is -- with itself, or with an anonymous type created for an attribute -- reference Access. - elsif Ekind_In (BT1, E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type) + elsif Ekind (BT1) in E_Anonymous_Access_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type and then Is_Access_Type (T2) and then (not Comes_From_Source (T1) or else not Comes_From_Source (T2)) @@ -1106,7 +1106,7 @@ package body Sem_Type is -- imposed by context. elsif Ekind (T2) = E_Access_Attribute_Type - and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) + and then Ekind (BT1) in E_General_Access_Type | E_Access_Type and then Covers (Designated_Type (T1), Designated_Type (T2)) then -- If the target type is a RACW type while the source is an access @@ -1599,10 +1599,10 @@ package body Sem_Type is and then Is_Overloaded (Act1) and then (Nkind (Act1) in N_Unary_Op - or else Nkind_In (Left_Opnd (Act1), N_Integer_Literal, - N_Real_Literal)) - and then Nkind_In (Right_Opnd (Act1), N_Integer_Literal, - N_Real_Literal) + or else Nkind (Left_Opnd (Act1)) in + N_Integer_Literal | N_Real_Literal) + and then Nkind (Right_Opnd (Act1)) in + N_Integer_Literal | N_Real_Literal and then Has_Compatible_Type (Act1, Standard_Boolean) and then Etype (F1) = Standard_Boolean then @@ -1627,8 +1627,8 @@ package body Sem_Type is elsif Present (Act2) and then Nkind (Act2) in N_Op and then Is_Overloaded (Act2) - and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal, - N_Real_Literal) + and then Nkind (Right_Opnd (Act2)) in + N_Integer_Literal | N_Real_Literal and then Has_Compatible_Type (Act2, Standard_Boolean) then -- The preference rule on the first actual is not @@ -2094,7 +2094,7 @@ package body Sem_Type is and then not In_Instance then if Is_Fixed_Point_Type (Typ) - and then Nam_In (Chars (Nam1), Name_Op_Multiply, Name_Op_Divide) + and then Chars (Nam1) in Name_Op_Multiply | Name_Op_Divide and then (Ada_Version = Ada_83 or else (Ada_Version >= Ada_2012 @@ -2114,7 +2114,7 @@ package body Sem_Type is -- declared in the same declarative list as the type. The node -- may be an operator or a function call. - elsif Nam_In (Chars (Nam1), Name_Op_Eq, Name_Op_Ne) + elsif Chars (Nam1) in Name_Op_Eq | Name_Op_Ne and then Ada_Version >= Ada_2005 and then Etype (User_Subp) = Standard_Boolean and then Is_Anonymous_Access_Type (Operand_Type) @@ -3105,7 +3105,7 @@ package body Sem_Type is elsif Num = 1 then T1 := Etype (New_First_F); - if Nam_In (Op_Name, Name_Op_Subtract, Name_Op_Add, Name_Op_Abs) then + if Op_Name in Name_Op_Subtract | Name_Op_Add | Name_Op_Abs then return Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T); @@ -3123,24 +3123,23 @@ package body Sem_Type is T1 := Etype (New_First_F); T2 := Etype (Next_Formal (New_First_F)); - if Nam_In (Op_Name, Name_Op_And, Name_Op_Or, Name_Op_Xor) then + if Op_Name in Name_Op_And | Name_Op_Or | Name_Op_Xor then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Valid_Boolean_Arg (Base_Type (T)); - elsif Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) then + elsif Op_Name in Name_Op_Eq | Name_Op_Ne then return Base_Type (T1) = Base_Type (T2) and then not Is_Limited_Type (T1) and then Is_Boolean_Type (T); - elsif Nam_In (Op_Name, Name_Op_Lt, Name_Op_Le, - Name_Op_Gt, Name_Op_Ge) + elsif Op_Name in Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge then return Base_Type (T1) = Base_Type (T2) and then Valid_Comparison_Arg (T1) and then Is_Boolean_Type (T); - elsif Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then + elsif Op_Name in Name_Op_Add | Name_Op_Subtract then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T); @@ -3193,7 +3192,7 @@ package body Sem_Type is and then Is_Floating_Point_Type (T2) and then Base_Type (T2) = Base_Type (T)); - elsif Nam_In (Op_Name, Name_Op_Mod, Name_Op_Rem) then + elsif Op_Name in Name_Op_Mod | Name_Op_Rem then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Is_Integer_Type (T); @@ -3423,26 +3422,26 @@ package body Sem_Type is then return T2; - elsif Ekind_In (B1, E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type) + elsif Ekind (B1) in E_Access_Subprogram_Type + | E_Access_Protected_Subprogram_Type and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type and then Is_Access_Type (T2) then return T2; - elsif Ekind_In (B2, E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type) + elsif Ekind (B2) in E_Access_Subprogram_Type + | E_Access_Protected_Subprogram_Type and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type and then Is_Access_Type (T1) then return T1; - elsif Ekind_In (T1, E_Allocator_Type, E_Access_Attribute_Type) + elsif Ekind (T1) in E_Allocator_Type | E_Access_Attribute_Type and then Is_Access_Type (T2) then return T2; - elsif Ekind_In (T2, E_Allocator_Type, E_Access_Attribute_Type) + elsif Ekind (T2) in E_Allocator_Type | E_Access_Attribute_Type and then Is_Access_Type (T1) then return T1; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 643eb21..a80cc5c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -195,8 +195,7 @@ package body Sem_Util is Nod := Declaration_Node (Base_Type (Typ)); - if Nkind_In (Nod, N_Full_Type_Declaration, - N_Private_Type_Declaration) + if Nkind (Nod) in N_Full_Type_Declaration | N_Private_Type_Declaration then return Empty_List; end if; @@ -1024,11 +1023,13 @@ package body Sem_Util is HSS : Node_Id; begin - pragma Assert (Nkind_In (N, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Subprogram_Body, - N_Task_Body)); + pragma Assert + (Nkind (N) in + N_Block_Statement | + N_Entry_Body | + N_Package_Body | + N_Subprogram_Body | + N_Task_Body); HSS := Handled_Statement_Sequence (N); @@ -2570,10 +2571,8 @@ package body Sem_Util is -- Don't collect identifiers of packages, called functions, etc - elsif Ekind_In (Entity (N), E_Package, - E_Function, - E_Procedure, - E_Entry) + elsif Ekind (Entity (N)) in + E_Package | E_Function | E_Procedure | E_Entry then return Skip; @@ -2593,9 +2592,8 @@ package body Sem_Util is -- to identify a corner case??? elsif Nkind (Parent (N)) = N_Component_Association - and then Nkind_In (Parent (Parent (N)), - N_Aggregate, - N_Extension_Aggregate) + and then Nkind (Parent (Parent (N))) in + N_Aggregate | N_Extension_Aggregate then declare Choice : constant Node_Id := First (Choices (Parent (N))); @@ -2629,15 +2627,15 @@ package body Sem_Util is return Abandon; end if; - if Ekind_In (Id, E_Function, E_Generic_Function) + if Ekind (Id) in E_Function | E_Generic_Function and then Has_Out_Or_In_Out_Parameter (Id) then Formal := First_Formal (Id); Actual := First_Actual (Call); while Present (Actual) and then Present (Formal) loop if Actual = N then - if Ekind_In (Formal, E_Out_Parameter, - E_In_Out_Parameter) + if Ekind (Formal) in E_Out_Parameter + | E_In_Out_Parameter then Is_Writable_Actual := True; end if; @@ -2788,15 +2786,15 @@ package body Sem_Util is if Ada_Version < Ada_2012 or else not Check_Actuals (N) - or else (not (Nkind (N) in N_Op) - and then not (Nkind (N) in N_Membership_Test) - and then not Nkind_In (N, N_Range, - N_Aggregate, - N_Extension_Aggregate, - N_Full_Type_Declaration, - N_Function_Call, - N_Procedure_Call_Statement, - N_Entry_Call_Statement)) + or else Nkind (N) not in N_Op + | N_Membership_Test + | N_Range + | N_Aggregate + | N_Extension_Aggregate + | N_Full_Type_Declaration + | N_Function_Call + | N_Procedure_Call_Statement + | N_Entry_Call_Statement or else (Nkind (N) = N_Full_Type_Declaration and then not Is_Record_Type (Defining_Identifier (N))) @@ -2836,7 +2834,7 @@ package body Sem_Util is Collect_Identifiers (Right_Opnd (N)); end if; - if Nkind_In (N, N_In, N_Not_In) + if Nkind (N) in N_In | N_Not_In and then Present (Alternatives (N)) then Expr := First (Alternatives (N)); @@ -2914,8 +2912,7 @@ package body Sem_Util is Formal := First_Formal (Id); Actual := First_Actual (N); while Present (Actual) and then Present (Formal) loop - if Ekind_In (Formal, E_Out_Parameter, - E_In_Out_Parameter) + if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter then Collect_Identifiers (Actual); end if; @@ -2982,8 +2979,8 @@ package body Sem_Util is -- Count several components - elsif Nkind_In (Choice, N_Range, - N_Subtype_Indication) + elsif Nkind (Choice) in + N_Range | N_Subtype_Indication or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) then @@ -3085,8 +3082,8 @@ package body Sem_Util is while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop - if Nkind_In (Choice, N_Range, - N_Subtype_Indication) + if Nkind (Choice) in + N_Range | N_Subtype_Indication or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) then @@ -3446,8 +3443,8 @@ package body Sem_Util is elsif Nkind (P) = N_Parameter_Specification and then Scope (Current_Scope) = Scope (Nam) - and then Nkind_In (Parent (P), N_Entry_Declaration, - N_Subprogram_Declaration) + and then Nkind (Parent (P)) in + N_Entry_Declaration | N_Subprogram_Declaration then Error_Msg_N ("internal call cannot appear in default for formal of " @@ -3516,7 +3513,8 @@ package body Sem_Util is -- Loop through sequence of basic declarative items Outer : while Present (Decl) loop - if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) + if Nkind (Decl) not in + N_Subprogram_Body | N_Package_Body | N_Task_Body and then Nkind (Decl) not in N_Body_Stub then Next (Decl); @@ -3554,7 +3552,7 @@ package body Sem_Util is Scop : Entity_Id; begin - pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable); -- Nothing to do for internally-generated abstract states and variables -- because they do not represent the hidden state of the source unit. @@ -3585,7 +3583,7 @@ package body Sem_Util is -- or a task. elsif Is_Subprogram_Or_Entry (Context) - or else Ekind_In (Context, E_Block, E_Task_Type) + or else Ekind (Context) in E_Block | E_Task_Type then return; end if; @@ -3803,7 +3801,7 @@ package body Sem_Util is -- Initial_Condition and Initializes as this is part of the -- elaboration checks for the constituent (SPARK RM 9(3)). - if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then + if Prag_Nam in Name_Initial_Condition | Name_Initializes then return; -- When the reference appears within pragma Depends or Global, @@ -3811,7 +3809,7 @@ package body Sem_Util is -- that the pragma may not encapsulated by the type definition, -- but this is still a valid context. - elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) + elsif Prag_Nam in Name_Depends | Name_Global and then Is_Single_Task_Pragma (Par, Conc_Obj) then return; @@ -3820,8 +3818,8 @@ package body Sem_Util is -- The reference appears somewhere in the definition of a single -- concurrent type (SPARK RM 9(3)). - elsif Nkind_In (Par, N_Single_Protected_Declaration, - N_Single_Task_Declaration) + elsif Nkind (Par) in + N_Single_Protected_Declaration | N_Single_Task_Declaration and then Defining_Entity (Par) = Conc_Obj then return; @@ -3829,10 +3827,10 @@ package body Sem_Util is -- The reference appears within the declaration or body of a single -- concurrent type (SPARK RM 9(3)). - elsif Nkind_In (Par, N_Protected_Body, - N_Protected_Type_Declaration, - N_Task_Body, - N_Task_Type_Declaration) + elsif Nkind (Par) in N_Protected_Body + | N_Protected_Type_Declaration + | N_Task_Body + | N_Task_Type_Declaration and then Is_Single_Declaration_Or_Body (Par, Conc_Obj) then return; @@ -3851,10 +3849,10 @@ package body Sem_Util is -- real check was already performed in the original context of the -- reference. - elsif Nkind_In (Par, N_Package_Body, - N_Package_Declaration, - N_Subprogram_Body, - N_Subprogram_Declaration) + elsif Nkind (Par) in N_Package_Body + | N_Package_Declaration + | N_Subprogram_Body + | N_Subprogram_Declaration and then Is_Internal_Declaration_Or_Body (Par) then return; @@ -4064,10 +4062,10 @@ package body Sem_Util is -- Empty list (no global items) or single global item -- declaration (only input items). - if Nkind_In (List, N_Null, - N_Expanded_Name, - N_Identifier, - N_Selected_Component) + if Nkind (List) in N_Null + | N_Expanded_Name + | N_Identifier + | N_Selected_Component then return False; @@ -4118,7 +4116,7 @@ package body Sem_Util is Param := First_Formal (Subp); while Present (Param) loop - if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then + if Ekind (Param) in E_Out_Parameter | E_In_Out_Parameter then return False; end if; @@ -4183,7 +4181,7 @@ package body Sem_Util is procedure Check_Conjuncts (Expr : Node_Id) is begin - if Nkind_In (Expr, N_Op_And, N_And_Then) then + if Nkind (Expr) in N_Op_And | N_And_Then then Check_Conjuncts (Left_Opnd (Expr)); Check_Conjuncts (Right_Opnd (Expr)); else @@ -4265,11 +4263,11 @@ package body Sem_Util is Ent : Entity_Id; begin - if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then + if Nkind (N) in N_Explicit_Dereference | N_Function_Call then Post_State_Seen := True; return Abandon; - elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then + elsif Nkind (N) in N_Expanded_Name | N_Identifier then Ent := Entity (N); -- Treat an undecorated reference as OK @@ -4279,10 +4277,10 @@ package body Sem_Util is -- A reference to an assignable entity is considered a -- change in the post-state of a subprogram. - or else Ekind_In (Ent, E_Generic_In_Out_Parameter, - E_In_Out_Parameter, - E_Out_Parameter, - E_Variable) + or else Ekind (Ent) in E_Generic_In_Out_Parameter + | E_In_Out_Parameter + | E_Out_Parameter + | E_Variable -- The reference may be modified through a dereference @@ -4340,8 +4338,7 @@ package body Sem_Util is -- Examine the expression of a postcondition - else pragma Assert (Nam_In (Nam, Name_Postcondition, - Name_Refined_Post)); + else pragma Assert (Nam in Name_Postcondition | Name_Refined_Post); Check_Expression (Expr); end if; end Check_Result_And_Post_State_In_Pragma; @@ -4415,8 +4412,8 @@ package body Sem_Util is Prag := Pre_Post_Conditions (Items); while Present (Prag) loop - if Nam_In (Pragma_Name_Unmapped (Prag), - Name_Postcondition, Name_Refined_Post) + if Pragma_Name_Unmapped (Prag) + in Name_Postcondition | Name_Refined_Post and then not Error_Posted (Prag) then Post_Prag := Prag; @@ -4443,7 +4440,7 @@ package body Sem_Util is -- Do not emit any errors if the subprogram is not a function - if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then + if Ekind (Spec_Id) not in E_Function | E_Generic_Function then null; -- Regardless of whether the function has postconditions or contract @@ -4576,8 +4573,8 @@ package body Sem_Util is if Present (Decls) then Decl := First (Decls); while Present (Decl) loop - if Nkind_In (Decl, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (Decl) in N_Generic_Package_Declaration + | N_Package_Declaration then Check_Package (Decl); end if; @@ -4620,10 +4617,10 @@ package body Sem_Util is -- An entry, protected, subprogram, or task body may declare a nested -- package. - elsif Nkind_In (Context, N_Entry_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Nkind (Context) in N_Entry_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body then -- Do not verify proper state refinement when the body is subject to -- pragma SPARK_Mode Off because this disables the requirement for @@ -4648,8 +4645,8 @@ package body Sem_Util is -- A library level [generic] package may declare a nested package - elsif Nkind_In (Context, N_Generic_Package_Declaration, - N_Package_Declaration) + elsif Nkind (Context) in + N_Generic_Package_Declaration | N_Package_Declaration and then Is_Main_Unit then Check_Package (Context); @@ -4702,7 +4699,7 @@ package body Sem_Util is -- For indexed and selected components, recursively check the prefix - if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then + if Nkind (Obj) in N_Indexed_Component | N_Selected_Component then return Enclosing_Protected_Type (Prefix (Obj)); -- The object does not denote a protected component @@ -4806,9 +4803,8 @@ package body Sem_Util is Constit_Id := Entity_Of (Constit); if Present (Constit_Id) - and then Ekind_In (Constit_Id, E_Abstract_State, - E_Constant, - E_Variable) + and then Ekind (Constit_Id) in + E_Abstract_State | E_Constant | E_Variable then Remove (States, Constit_Id); end if; @@ -5080,7 +5076,7 @@ package body Sem_Util is elsif Ekind (Item_Id) = E_Abstract_State then Append_New_Elmt (Item_Id, States); - elsif Ekind_In (Item_Id, E_Constant, E_Variable) + elsif Ekind (Item_Id) in E_Constant | E_Variable and then Is_Visible_Object (Item_Id) then Append_New_Elmt (Item_Id, States); @@ -6422,8 +6418,28 @@ package body Sem_Util is function Is_Renaming (N : Node_Id) return Boolean is begin - return - Is_Entity_Name (N) and then Present (Renamed_Entity (Entity (N))); + if not Is_Entity_Name (N) then + return False; + end if; + + case Ekind (Entity (N)) is + when E_Variable | E_Constant => + return Present (Renamed_Object (Entity (N))); + + when E_Exception + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Operator + | E_Package + | E_Procedure + => + return Present (Renamed_Entity (Entity (N))); + + when others => + return False; + end case; end Is_Renaming; ----------------------- @@ -6650,7 +6666,7 @@ package body Sem_Util is function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is begin if Is_Entity_Name (A1) then - if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) + if Nkind (A2) in N_Selected_Component | N_Indexed_Component and then not Is_Access_Type (Etype (A1)) then return Denotes_Same_Object (A1, Prefix (A2)) @@ -6662,9 +6678,9 @@ package body Sem_Util is elsif Is_Entity_Name (A2) then return Denotes_Same_Prefix (A1 => A2, A2 => A1); - elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) + elsif Nkind (A1) in N_Selected_Component | N_Indexed_Component | N_Slice and then - Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) + Nkind (A2) in N_Selected_Component | N_Indexed_Component | N_Slice then declare Root1, Root2 : Node_Id; @@ -6673,8 +6689,8 @@ package body Sem_Util is begin Root1 := Prefix (A1); while not Is_Entity_Name (Root1) loop - if not Nkind_In - (Root1, N_Selected_Component, N_Indexed_Component) + if Nkind (Root1) not in + N_Selected_Component | N_Indexed_Component then return False; else @@ -6686,8 +6702,8 @@ package body Sem_Util is Root2 := Prefix (A2); while not Is_Entity_Name (Root2) loop - if not Nkind_In (Root2, N_Selected_Component, - N_Indexed_Component) + if Nkind (Root2) not in + N_Selected_Component | N_Indexed_Component then return False; else @@ -6797,19 +6813,19 @@ package body Sem_Util is -- Start of processing for Designate_Same_Unit begin - if Nkind_In (K1, N_Identifier, N_Defining_Identifier) + if K1 in N_Identifier | N_Defining_Identifier and then - Nkind_In (K2, N_Identifier, N_Defining_Identifier) + K2 in N_Identifier | N_Defining_Identifier then return Chars (Name1) = Chars (Name2); - elsif Nkind_In (K1, N_Expanded_Name, - N_Selected_Component, - N_Defining_Program_Unit_Name) - and then - Nkind_In (K2, N_Expanded_Name, - N_Selected_Component, - N_Defining_Program_Unit_Name) + elsif K1 in N_Expanded_Name + | N_Selected_Component + | N_Defining_Program_Unit_Name + and then + K2 in N_Expanded_Name + | N_Selected_Component + | N_Defining_Program_Unit_Name then return (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) @@ -6905,7 +6921,7 @@ package body Sem_Util is end if; if (Is_Formal (E) - or else Ekind_In (E, E_Variable, E_Constant)) + or else Ekind (E) in E_Variable | E_Constant) and then Present (Get_Accessibility (E)) then return New_Occurrence_Of (Get_Accessibility (E), Loc); @@ -6915,7 +6931,7 @@ package body Sem_Util is -- Handle a constant-folded conditional expression by avoiding use of -- the original node. - if Nkind_In (Expr, N_Case_Expression, N_If_Expression) then + if Nkind (Expr) in N_Case_Expression | N_If_Expression then Expr := N; end if; @@ -7234,13 +7250,13 @@ package body Sem_Util is begin Par := Parent (N); while Present (Par) loop - if Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + if Nkind (Par) in N_Package_Body | N_Subprogram_Body then Spec_Id := Corresponding_Spec (Par); if Present (Spec_Id) - and then Nkind_In (Unit_Declaration_Node (Spec_Id), - N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration) + and then Nkind (Unit_Declaration_Node (Spec_Id)) in + N_Generic_Package_Declaration | + N_Generic_Subprogram_Declaration then return Par; end if; @@ -7264,19 +7280,19 @@ package body Sem_Util is begin Par := Parent (N); while Present (Par) loop - if Nkind_In (Par, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration) + if Nkind (Par) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration then return Par; - elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + elsif Nkind (Par) in N_Package_Body | N_Subprogram_Body then Spec_Id := Corresponding_Spec (Par); if Present (Spec_Id) then Spec_Decl := Unit_Declaration_Node (Spec_Id); - if Nkind_In (Spec_Decl, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration) + if Nkind (Spec_Decl) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration then return Spec_Decl; end if; @@ -7346,9 +7362,8 @@ package body Sem_Util is elsif Dynamic_Scope = Empty then return Empty; - elsif Ekind_In (Dynamic_Scope, E_Generic_Package, - E_Package, - E_Package_Body) + elsif Ekind (Dynamic_Scope) in + E_Generic_Package | E_Package | E_Package_Body then return Dynamic_Scope; @@ -7397,10 +7412,10 @@ package body Sem_Util is elsif Ekind (Dyn_Scop) = E_Subprogram_Body then return Corresponding_Spec (Parent (Parent (Dyn_Scop))); - elsif Ekind_In (Dyn_Scop, E_Block, E_Loop, E_Return_Statement) then + elsif Ekind (Dyn_Scop) in E_Block | E_Loop | E_Return_Statement then return Enclosing_Subprogram (Dyn_Scop); - elsif Ekind_In (Dyn_Scop, E_Entry, E_Entry_Family) then + elsif Ekind (Dyn_Scop) in E_Entry | E_Entry_Family then -- For a task entry or entry family, return the enclosing subprogram -- of the task itself. @@ -7422,10 +7437,10 @@ package body Sem_Util is -- The scope may appear as a private type or as a private extension -- whose completion is a task or protected type. - elsif Ekind_In (Dyn_Scop, E_Limited_Private_Type, - E_Record_Type_With_Private) + elsif Ekind (Dyn_Scop) in + E_Limited_Private_Type | E_Record_Type_With_Private and then Present (Full_View (Dyn_Scop)) - and then Ekind_In (Full_View (Dyn_Scop), E_Task_Type, E_Protected_Type) + and then Ekind (Full_View (Dyn_Scop)) in E_Task_Type | E_Protected_Type then return Get_Task_Body_Procedure (Full_View (Dyn_Scop)); @@ -7483,11 +7498,11 @@ package body Sem_Util is -- Start of processing for End_Keyword_Location begin - if Nkind_In (N, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Subprogram_Body, - N_Task_Body) + if Nkind (N) in N_Block_Statement + | N_Entry_Body + | N_Package_Body + | N_Subprogram_Body + | N_Task_Body then Owner := Handled_Statement_Sequence (N); @@ -7497,13 +7512,12 @@ package body Sem_Util is elsif Nkind (N) = N_Protected_Body then Owner := N; - elsif Nkind_In (N, N_Protected_Type_Declaration, - N_Single_Protected_Declaration) + elsif Nkind (N) in N_Protected_Type_Declaration + | N_Single_Protected_Declaration then Owner := Protected_Definition (N); - elsif Nkind_In (N, N_Single_Task_Declaration, - N_Task_Type_Declaration) + elsif Nkind (N) in N_Single_Task_Declaration | N_Task_Type_Declaration then Owner := Task_Definition (N); @@ -7759,7 +7773,7 @@ package body Sem_Util is -- Avoid cascaded messages with duplicate components in -- derived types. - if Ekind_In (E, E_Component, E_Discriminant) then + if Ekind (E) in E_Component | E_Discriminant then return; end if; end if; @@ -7794,7 +7808,7 @@ package body Sem_Util is -- of inheriting components in a derived record definition. Preserve -- their Ekind and Etype. - if Ekind_In (Def_Id, E_Discriminant, E_Component) then + if Ekind (Def_Id) in E_Discriminant | E_Component then null; -- If a type is already set, leave it alone (happens when a type @@ -7817,7 +7831,7 @@ package body Sem_Util is -- Unless the Itype is for a record type with a corresponding remote -- type (what is that about, it was not commented ???) - if Ekind_In (Def_Id, E_Discriminant, E_Component) + if Ekind (Def_Id) in E_Discriminant | E_Component or else ((not Is_Record_Type (Def_Id) or else No (Corresponding_Remote_Type (Def_Id))) @@ -8169,8 +8183,7 @@ package body Sem_Util is elsif Comes_From_Source (Decl) or else - (Nkind_In (Decl, N_Subprogram_Body, - N_Subprogram_Declaration) + (Nkind (Decl) in N_Subprogram_Body | N_Subprogram_Declaration and then Is_Expression_Function (Defining_Entity (Decl))) then exit; @@ -8242,7 +8255,7 @@ package body Sem_Util is Call_Nam : Node_Id; begin - if Nkind_In (Context, N_Indexed_Component, N_Selected_Component) + if Nkind (Context) in N_Indexed_Component | N_Selected_Component and then N = Prefix (Context) then Find_Actual (Context, Formal, Call); @@ -8253,9 +8266,9 @@ package body Sem_Util is then Call := Parent (Context); - elsif Nkind_In (Context, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + elsif Nkind (Context) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then Call := Context; @@ -8269,9 +8282,9 @@ package body Sem_Util is -- we exclude overloaded calls, since we don't know enough to be sure -- of giving the right answer in this case. - if Nkind_In (Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (Call) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then Call_Nam := Name (Call); @@ -8671,7 +8684,7 @@ package body Sem_Util is Expr := Prefix (Expr); exit; - -- Check for Const where Const is a constant entity + -- Check for Const where Const is a constant entity elsif Is_Entity_Name (Expr) and then Ekind (Entity (Expr)) = E_Constant @@ -8697,8 +8710,7 @@ package body Sem_Util is -- Check for components - elsif - Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) + elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component then Expr := Prefix (Expr); Off := True; @@ -9049,7 +9061,7 @@ package body Sem_Util is -- Single global item declaration (only input items) - elsif Nkind_In (List, N_Expanded_Name, N_Identifier) then + elsif Nkind (List) in N_Expanded_Name | N_Identifier then if Global_Mode = Name_Input then return List; else @@ -9103,10 +9115,10 @@ package body Sem_Util is -- Start of processing for First_Global begin - pragma Assert (Nam_In (Global_Mode, Name_In_Out, - Name_Input, - Name_Output, - Name_Proof_In)); + pragma Assert (Global_Mode in Name_In_Out + | Name_Input + | Name_Output + | Name_Proof_In); -- Retrieve the suitable pragma Global or Refined_Global. In the second -- case, it can only be located on the body entity. @@ -9155,7 +9167,7 @@ package body Sem_Util is function Fix_Msg (Id : Entity_Id; Msg : String) return String is Is_Task : constant Boolean := - Ekind_In (Id, E_Task_Body, E_Task_Type) + Ekind (Id) in E_Task_Body | E_Task_Type or else Is_Single_Task_Object (Id); Msg_Last : constant Natural := Msg'Last; Msg_Index : Natural; @@ -9946,6 +9958,79 @@ package body Sem_Util is end if; end Get_Enum_Lit_From_Pos; + ---------------------- + -- Get_Fullest_View -- + ---------------------- + + function Get_Fullest_View + (E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id is + begin + -- Strictly speaking, the recursion below isn't necessary, but + -- it's both simplest and safest. + + case Ekind (E) is + when Incomplete_Kind => + if From_Limited_With (E) then + return Get_Fullest_View (Non_Limited_View (E), Include_PAT); + elsif Present (Full_View (E)) then + return Get_Fullest_View (Full_View (E), Include_PAT); + elsif Ekind (E) = E_Incomplete_Subtype then + return Get_Fullest_View (Etype (E)); + end if; + + when Private_Kind => + if Present (Underlying_Full_View (E)) then + return + Get_Fullest_View (Underlying_Full_View (E), Include_PAT); + elsif Present (Full_View (E)) then + return Get_Fullest_View (Full_View (E), Include_PAT); + elsif Etype (E) /= E then + return Get_Fullest_View (Etype (E), Include_PAT); + end if; + + when Array_Kind => + if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then + return Get_Fullest_View (Packed_Array_Impl_Type (E)); + end if; + + when E_Record_Subtype => + if Present (Cloned_Subtype (E)) then + return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); + end if; + + when E_Class_Wide_Type => + return Get_Fullest_View (Root_Type (E), Include_PAT); + + when E_Class_Wide_Subtype => + if Present (Equivalent_Type (E)) then + return Get_Fullest_View (Equivalent_Type (E), Include_PAT); + elsif Present (Cloned_Subtype (E)) then + return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); + end if; + + when E_Protected_Type | E_Protected_Subtype + | E_Task_Type | E_Task_Subtype => + if Present (Corresponding_Record_Type (E)) then + return Get_Fullest_View (Corresponding_Record_Type (E), + Include_PAT); + end if; + + when E_Access_Protected_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type => + if Present (Equivalent_Type (E)) then + return Get_Fullest_View (Equivalent_Type (E), Include_PAT); + end if; + + when E_Access_Subtype => + return Get_Fullest_View (Base_Type (E), Include_PAT); + + when others => + null; + end case; + + return E; + end Get_Fullest_View; + ------------------------ -- Get_Generic_Entity -- ------------------------ @@ -10198,12 +10283,12 @@ package body Sem_Util is pragma Assert (Is_Type (Typ) and then - Nam_In (Nam, Name_Element, - Name_First, - Name_Has_Element, - Name_Last, - Name_Next, - Name_Previous)); + Nam in Name_Element + | Name_First + | Name_Has_Element + | Name_Last + | Name_Next + | Name_Previous); Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); Assoc : Node_Id; @@ -10506,14 +10591,14 @@ package body Sem_Util is -- Strip the subprogram call loop - if Nkind_In (Subp, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component) + if Nkind (Subp) in N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component then Subp := Prefix (Subp); - elsif Nkind_In (Subp, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Subp) in N_Type_Conversion + | N_Unchecked_Type_Conversion then Subp := Expression (Subp); @@ -10647,14 +10732,14 @@ package body Sem_Util is UFull_Typ := Underlying_Full_View (Full_Typ); if Present (UFull_Typ) - and then Ekind_In (UFull_Typ, E_Protected_Type, E_Task_Type) + and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type then CRec_Typ := Corresponding_Record_Type (UFull_Typ); end if; else if Present (Full_Typ) - and then Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) + and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type then CRec_Typ := Corresponding_Record_Type (Full_Typ); end if; @@ -11049,15 +11134,15 @@ package body Sem_Util is function Has_Declarations (N : Node_Id) return Boolean is begin - return Nkind_In (Nkind (N), N_Accept_Statement, - N_Block_Statement, - N_Compilation_Unit_Aux, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body, - N_Package_Specification); + return Nkind (N) in N_Accept_Statement + | N_Block_Statement + | N_Compilation_Unit_Aux + | N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body + | N_Package_Specification; end Has_Declarations; --------------------------------- @@ -11159,7 +11244,7 @@ package body Sem_Util is -- Inspect the return type of functions - if Ekind_In (Subp_Id, E_Function, E_Generic_Function) + if Ekind (Subp_Id) in E_Function | E_Generic_Function and then Is_Effectively_Volatile (Etype (Subp_Id)) then return True; @@ -11386,7 +11471,7 @@ package body Sem_Util is -- Synchronous (SPARK RM 7.1.4(9)). elsif Has_Synchronous then - return Nam_In (Property, Name_Async_Readers, Name_Async_Writers); + return Property in Name_Async_Readers | Name_Async_Writers; end if; return False; @@ -11808,12 +11893,10 @@ package body Sem_Util is elsif Nkind (N) in N_Has_Entity then return Present (Entity (N)) - and then Ekind_In (Entity (N), E_Variable, - E_Constant, - E_Enumeration_Literal, - E_In_Parameter, - E_Out_Parameter, - E_In_Out_Parameter) + and then + Ekind (Entity (N)) in + E_Variable | E_Constant | E_Enumeration_Literal | + E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter and then not Is_Volatile (Entity (N)); else @@ -11852,7 +11935,7 @@ package body Sem_Util is Node := First (L); loop - if not Nkind_In (Node, N_Null_Statement, N_Call_Marker) then + if Nkind (Node) not in N_Null_Statement | N_Call_Marker then return True; end if; @@ -12400,14 +12483,10 @@ package body Sem_Util is function Has_Prefix (N : Node_Id) return Boolean is begin - return - Nkind_In (N, N_Attribute_Reference, - N_Expanded_Name, - N_Explicit_Dereference, - N_Indexed_Component, - N_Reference, - N_Selected_Component, - N_Slice); + return Nkind (N) in + N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference | + N_Indexed_Component | N_Reference | N_Selected_Component | + N_Slice; end Has_Prefix; --------------------------- @@ -12490,11 +12569,9 @@ package body Sem_Util is function Denotes_Relaxed_Parameter (Expr : Node_Id; - Param : Entity_Id) - return Boolean - is + Param : Entity_Id) return Boolean is begin - if Nkind_In (Expr, N_Identifier, N_Expanded_Name) then + if Nkind (Expr) in N_Identifier | N_Expanded_Name then return Entity (Expr) = Param; else pragma Assert (Is_Attribute_Result (Expr)); @@ -12785,13 +12862,9 @@ package body Sem_Util is begin pragma Assert (Relaxed_RM_Semantics); - pragma Assert (Nkind_In (N, N_Null, - N_Op_Eq, - N_Op_Ge, - N_Op_Gt, - N_Op_Le, - N_Op_Lt, - N_Op_Ne)); + pragma Assert + (Nkind (N) in + N_Null | N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne); if Nkind (N) = N_Null then Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); @@ -13139,7 +13212,7 @@ package body Sem_Util is begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop - if Ekind_In (S, E_Function, E_Procedure) + if Ekind (S) in E_Function | E_Procedure and then Is_Generic_Instance (S) then return True; @@ -13167,7 +13240,7 @@ package body Sem_Util is begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop - if Ekind_In (S, E_Function, E_Procedure) + if Ekind (S) in E_Function | E_Procedure and then Is_Generic_Instance (S) then return True; @@ -13371,15 +13444,15 @@ package body Sem_Util is if Nod = Cont then return True; - elsif Nkind_In (Nod, N_Accept_Statement, - N_Block_Statement, - N_Compilation_Unit, - N_Entry_Body, - N_Package_Body, - N_Package_Declaration, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Nkind (Nod) in N_Accept_Statement + | N_Block_Statement + | N_Compilation_Unit + | N_Entry_Body + | N_Package_Body + | N_Package_Declaration + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body then return False; @@ -13544,9 +13617,9 @@ package body Sem_Util is -- declaration hold the partial view and the full view is an -- itype. - elsif Nkind_In (Decl, N_Full_Type_Declaration, - N_Private_Extension_Declaration, - N_Private_Type_Declaration) + elsif Nkind (Decl) in N_Full_Type_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration then Match := Defining_Identifier (Decl); end if; @@ -13963,13 +14036,12 @@ package body Sem_Util is -- For a retrieval of a subcomponent of some composite object, -- retrieve the ultimate entity if there is one. - elsif Nkind_In (New_Prefix, N_Selected_Component, - N_Indexed_Component) + elsif Nkind (New_Prefix) in N_Selected_Component | N_Indexed_Component then Pref := Prefix (New_Prefix); while Present (Pref) - and then Nkind_In (Pref, N_Selected_Component, - N_Indexed_Component) + and then Nkind (Pref) in + N_Selected_Component | N_Indexed_Component loop Pref := Prefix (Pref); end loop; @@ -14256,9 +14328,9 @@ package body Sem_Util is Par := Parent (N); while Present (Par) - and then Nkind_In (Par, N_Case_Expression, - N_If_Expression, - N_Parameter_Association) + and then Nkind (Par) in N_Case_Expression + | N_If_Expression + | N_Parameter_Association loop Par := Parent (Par); end loop; @@ -14277,6 +14349,18 @@ package body Sem_Util is return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; end Is_Actual_Out_Parameter; + -------------------------------- + -- Is_Actual_In_Out_Parameter -- + -------------------------------- + + function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean is + Formal : Entity_Id; + Call : Node_Id; + begin + Find_Actual (N, Formal, Call); + return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter; + end Is_Actual_In_Out_Parameter; + ------------------------- -- Is_Actual_Parameter -- ------------------------- @@ -14362,7 +14446,7 @@ package body Sem_Util is and then Has_Aliased_Components (Designated_Type (Etype (Prefix (Obj))))); - elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then + elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then return Is_Tagged_Type (Etype (Obj)) and then Is_Aliased_View (Expression (Obj)); @@ -14545,6 +14629,17 @@ package body Sem_Util is Is_RTE (Root_Type (Under), RO_WW_Super_String)); end Is_Bounded_String; + ------------------------------- + -- Is_By_Protected_Procedure -- + ------------------------------- + + function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean is + begin + return Ekind (Id) = E_Procedure + and then Present (Get_Rep_Pragma (Id, Name_Implemented)) + and then Implementation_Kind (Id) = Name_By_Protected_Procedure; + end Is_By_Protected_Procedure; + --------------------- -- Is_CCT_Instance -- --------------------- @@ -14554,21 +14649,17 @@ package body Sem_Util is Context_Id : Entity_Id) return Boolean is begin - pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type)); + pragma Assert (Ekind (Ref_Id) in E_Protected_Type | E_Task_Type); if Is_Single_Task_Object (Context_Id) then return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id); else - pragma Assert (Ekind_In (Context_Id, E_Entry, - E_Entry_Family, - E_Function, - E_Package, - E_Procedure, - E_Protected_Type, - E_Task_Type) - or else - Is_Record_Type (Context_Id)); + pragma Assert + (Ekind (Context_Id) in + E_Entry | E_Entry_Family | E_Function | E_Package | + E_Procedure | E_Protected_Type | E_Task_Type + or else Is_Record_Type (Context_Id)); return Scope_Within_Or_Same (Context_Id, Ref_Id); end if; end Is_CCT_Instance; @@ -14882,10 +14973,10 @@ package body Sem_Util is elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then return False; - elsif Nkind_In - (Nkind (Parent (Par)), N_Function_Call, - N_Procedure_Call_Statement, - N_Entry_Call_Statement) + elsif Nkind (Parent (Par)) in + N_Function_Call | + N_Procedure_Call_Statement | + N_Entry_Call_Statement then -- Check that the element is not part of an actual for an -- in-out parameter. @@ -15045,9 +15136,9 @@ package body Sem_Util is P := Parent (N); while Present (P) loop - if Nkind_In (P, N_Full_Type_Declaration, - N_Private_Type_Declaration, - N_Subtype_Declaration) + if Nkind (P) in N_Full_Type_Declaration + | N_Private_Type_Declaration + | N_Subtype_Declaration and then Comes_From_Source (P) and then Defining_Entity (P) = Typ then @@ -15098,7 +15189,7 @@ package body Sem_Util is if Is_Entity_Name (N) then return Present (Entity (N)) and then Ekind (Entity (N)) = E_In_Parameter - and then Ekind_In (Scope (Entity (N)), E_Function, E_Procedure) + and then Ekind (Scope (Entity (N))) in E_Function | E_Procedure and then (Is_Predicate_Function (Scope (Entity (N))) or else Is_Predicate_Function_M (Scope (Entity (N))) @@ -15275,9 +15366,8 @@ package body Sem_Util is begin -- Find the dereference node if any - while Nkind_In (Deref, N_Indexed_Component, - N_Selected_Component, - N_Slice) + while Nkind (Deref) in + N_Indexed_Component | N_Selected_Component | N_Slice loop Deref := Prefix (Deref); end loop; @@ -15313,8 +15403,8 @@ package body Sem_Util is -- False (it could be a function selector in a prefix form call -- occurring in an iterator specification). - if not Ekind_In (Entity (Selector_Name (Object)), E_Component, - E_Discriminant) + if Ekind (Entity (Selector_Name (Object))) not in + E_Component | E_Discriminant then return False; end if; @@ -15480,10 +15570,10 @@ package body Sem_Util is function Is_Dereferenced (N : Node_Id) return Boolean is P : constant Node_Id := Parent (N); begin - return Nkind_In (P, N_Selected_Component, - N_Explicit_Dereference, - N_Indexed_Component, - N_Slice) + return Nkind (P) in N_Selected_Component + | N_Explicit_Dereference + | N_Indexed_Component + | N_Slice and then Prefix (P) = N; end Is_Dereferenced; @@ -15615,22 +15705,24 @@ package body Sem_Util is -- effectively volatile. elsif Is_Array_Type (Id) then - declare - Anc : Entity_Id := Base_Type (Id); - begin - if Is_Private_Type (Anc) then - Anc := Full_View (Anc); - end if; + if Has_Volatile_Components (Id) then + return True; + else + declare + Anc : Entity_Id := Base_Type (Id); + begin + if Is_Private_Type (Anc) then + Anc := Full_View (Anc); + end if; - -- Test for presence of ancestor, as the full view of a private - -- type may be missing in case of error. + -- Test for presence of ancestor, as the full view of a + -- private type may be missing in case of error. - return - Has_Volatile_Components (Id) - or else - (Present (Anc) - and then Is_Effectively_Volatile (Component_Type (Anc))); - end; + return + Present (Anc) + and then Is_Effectively_Volatile (Component_Type (Anc)); + end; + end if; -- A protected type is always volatile @@ -15674,7 +15766,7 @@ package body Sem_Util is return Is_Object (Entity (N)) and then Is_Effectively_Volatile (Entity (N)); - elsif Nkind (N) = N_Indexed_Component then + elsif Nkind (N) in N_Indexed_Component | N_Slice then return Is_Effectively_Volatile_Object (Prefix (N)); elsif Nkind (N) = N_Selected_Component then @@ -15683,6 +15775,12 @@ package body Sem_Util is or else Is_Effectively_Volatile_Object (Selector_Name (N)); + elsif Nkind (N) in N_Qualified_Expression + | N_Unchecked_Type_Conversion + | N_Type_Conversion + then + return Is_Effectively_Volatile_Object (Expression (N)); + else return False; end if; @@ -15730,7 +15828,7 @@ package body Sem_Util is function Is_Expression_Function (Subp : Entity_Id) return Boolean is begin - if Ekind_In (Subp, E_Function, E_Subprogram_Body) then + if Ekind (Subp) in E_Function | E_Subprogram_Body then return Nkind (Original_Node (Unit_Declaration_Node (Subp))) = N_Expression_Function; @@ -15825,9 +15923,9 @@ package body Sem_Util is -- A qualified expression or a type conversion is an EVF expression when -- its operand is an EVF expression. - elsif Nkind_In (N, N_Qualified_Expression, - N_Unchecked_Type_Conversion, - N_Type_Conversion) + elsif Nkind (N) in N_Qualified_Expression + | N_Unchecked_Type_Conversion + | N_Type_Conversion then return Is_EVF_Expression (Expression (N)); @@ -15835,9 +15933,9 @@ package body Sem_Util is -- their prefix denotes an EVF expression. elsif Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Loop_Entry, - Name_Old, - Name_Update) + and then Attribute_Name (N) in Name_Loop_Entry + | Name_Old + | Name_Update then return Is_EVF_Expression (Prefix (N)); end if; @@ -16163,14 +16261,14 @@ package body Sem_Util is begin -- Package/subprogram body - if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body) + if Nkind (Decl) in N_Package_Body | N_Subprogram_Body and then Present (Corresponding_Spec (Decl)) then Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); -- Package/subprogram body stub - elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub) + elsif Nkind (Decl) in N_Package_Body_Stub | N_Subprogram_Body_Stub and then Present (Corresponding_Spec_Of_Stub (Decl)) then Spec_Decl := @@ -16188,8 +16286,8 @@ package body Sem_Util is -- calls. return - Nkind_In (Spec_Decl, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration); + Nkind (Spec_Decl) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration; end Is_Generic_Declaration_Or_Body; --------------------------- @@ -16348,8 +16446,7 @@ package body Sem_Util is -- a predefined unit, i.e the one that declares iterator interfaces. return - Nam_In (Chars (Iter_Typ), Name_Forward_Iterator, - Name_Reversible_Iterator) + Chars (Iter_Typ) in Name_Forward_Iterator | Name_Reversible_Iterator and then In_Predefined_Unit (Root_Type (Iter_Typ)); end Denotes_Iterator; @@ -16425,7 +16522,7 @@ package body Sem_Util is -- Case of prefix of indexed or selected component or slice - elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) + elsif Nkind (P) in N_Indexed_Component | N_Selected_Component | N_Slice and then N = Prefix (P) then -- Here we have the case where the parent P is N.Q or N(Q .. R). @@ -16503,7 +16600,7 @@ package body Sem_Util is Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin - if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then + if Ekind (Ent) not in E_Variable | E_In_Out_Parameter then return False; else return Present (Sub) and then Sub = Current_Subprogram; @@ -16533,8 +16630,7 @@ package body Sem_Util is -- Attributes 'Input, 'Old and 'Result produce objects when N_Attribute_Reference => - return - Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result); + return Attribute_Name (N) in Name_Input | Name_Old | Name_Result; when N_Selected_Component => return @@ -16983,7 +17079,7 @@ package body Sem_Util is if Ekind (Id) = E_Discriminant then null; - elsif Ekind_In (Id, E_Constant, E_In_Parameter) + elsif Ekind (Id) in E_Constant | E_In_Parameter and then Present (Discriminal_Link (Id)) then null; @@ -17122,10 +17218,10 @@ package body Sem_Util is when N_Attribute_Reference => return - Nam_In (Attribute_Name (N), Name_Loop_Entry, - Name_Old, - Name_Priority, - Name_Result) + Attribute_Name (N) in Name_Loop_Entry + | Name_Old + | Name_Priority + | Name_Result or else Is_Function_Attribute_Name (Attribute_Name (N)); when N_Selected_Component => @@ -17141,8 +17237,8 @@ package body Sem_Util is -- names. when N_Explicit_Dereference => - return not Nkind_In (Original_Node (N), N_Case_Expression, - N_If_Expression); + return Nkind (Original_Node (N)) not in + N_Case_Expression | N_If_Expression; -- A view conversion of a tagged object is an object reference @@ -17189,6 +17285,11 @@ package body Sem_Util is return Is_Rewrite_Substitution (N) and then Is_Object_Reference (Original_Node (N)); + -- AI12-0125: Target name represents a constant object + + when N_Target_Name => + return True; + when others => return False; end case; @@ -17236,7 +17337,7 @@ package body Sem_Util is -- expansion of a packed array aggregate). elsif Nkind (AV) = N_Unchecked_Type_Conversion then - if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then + if Nkind (Original_Node (AV)) in N_Function_Call | N_Aggregate then return False; elsif Comes_From_Source (AV) @@ -17332,10 +17433,8 @@ package body Sem_Util is and then Is_Protected_Type (Etype (Pref)) and then Is_Entity_Name (Subp) and then Present (Entity (Subp)) - and then Ekind_In (Entity (Subp), E_Entry, - E_Entry_Family, - E_Function, - E_Procedure); + and then Ekind (Entity (Subp)) in + E_Entry | E_Entry_Family | E_Function | E_Procedure; else return False; end if; @@ -17380,7 +17479,7 @@ package body Sem_Util is Func_Id := Id; while Present (Func_Id) and then Func_Id /= Standard_Standard loop - if Ekind_In (Func_Id, E_Function, E_Generic_Function) then + if Ekind (Func_Id) in E_Function | E_Generic_Function then return Is_Volatile_Function (Func_Id); end if; @@ -17460,11 +17559,12 @@ package body Sem_Util is -- The volatile object appears as the prefix of a name occurring in a -- non-interfering context. - elsif Nkind_In (Context, N_Attribute_Reference, - N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) + elsif Nkind (Context) in + N_Attribute_Reference | + N_Explicit_Dereference | + N_Indexed_Component | + N_Selected_Component | + N_Slice and then Prefix (Context) = Obj_Ref and then Is_OK_Volatile_Context (Context => Parent (Context), @@ -17478,25 +17578,26 @@ package body Sem_Util is elsif Nkind (Context) = N_Attribute_Reference and then Prefix (Context) = Obj_Ref - and then Nam_In (Attribute_Name (Context), Name_Address, - Name_Alignment, - Name_Component_Size, - Name_First, - Name_First_Bit, - Name_Last, - Name_Last_Bit, - Name_Length, - Name_Position, - Name_Size, - Name_Storage_Size) + and then Attribute_Name (Context) in Name_Address + | Name_Alignment + | Name_Component_Size + | Name_First + | Name_First_Bit + | Name_Last + | Name_Last_Bit + | Name_Length + | Name_Position + | Name_Size + | Name_Storage_Size then return True; -- The volatile object appears as the expression of a type conversion -- occurring in a non-interfering context. - elsif Nkind_In (Context, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Context) in N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion and then Expression (Context) = Obj_Ref and then Is_OK_Volatile_Context (Context => Parent (Context), @@ -17812,10 +17913,10 @@ package body Sem_Util is elsif Nkind (Par) = N_Case_Expression then return Expr /= Expression (Par); - elsif Nkind_In (Par, N_And_Then, N_Or_Else) then + elsif Nkind (Par) in N_And_Then | N_Or_Else then return Expr = Right_Opnd (Par); - elsif Nkind_In (Par, N_In, N_Not_In) then + elsif Nkind (Par) in N_In | N_Not_In then -- If the membership includes several alternatives, only the first -- is definitely evaluated. @@ -18011,7 +18112,7 @@ package body Sem_Util is TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); - if Nam_In (Chars (E), Name_uAssign, Name_uSize) + if Chars (E) in Name_uAssign | Name_uSize or else (Chars (E) = Name_Op_Eq and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) @@ -18042,12 +18143,12 @@ package body Sem_Util is -- these primitives. return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) - and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select, - Name_uDisp_Conditional_Select, - Name_uDisp_Get_Prim_Op_Kind, - Name_uDisp_Get_Task_Id, - Name_uDisp_Requeue, - Name_uDisp_Timed_Select); + and then Chars (E) in Name_uDisp_Asynchronous_Select + | Name_uDisp_Conditional_Select + | Name_uDisp_Get_Prim_Op_Kind + | Name_uDisp_Get_Task_Id + | Name_uDisp_Requeue + | Name_uDisp_Timed_Select; end Is_Predefined_Interface_Primitive; --------------------------------------- @@ -18075,7 +18176,7 @@ package body Sem_Util is TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); - if Nam_In (Chars (E), Name_uSize, Name_uAssign) + if Chars (E) in Name_uSize | Name_uAssign or else (Chars (E) = Name_Op_Eq and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) @@ -18205,7 +18306,7 @@ package body Sem_Util is begin -- Aggregates - if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + if Nkind (N) in N_Aggregate | N_Extension_Aggregate then return Is_Preelaborable_Aggregate (N); -- Attributes are allowed in general, even if their prefix is a formal @@ -18230,7 +18331,7 @@ package body Sem_Util is and then Present (Entity (N)) and then (Ekind (Entity (N)) = E_Discriminant - or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) + or else (Ekind (Entity (N)) in E_Constant | E_In_Parameter and then Present (Discriminal_Link (Entity (N))))) then return True; @@ -18564,12 +18665,12 @@ package body Sem_Util is begin if not Is_List_Member (N) then declare - P : constant Node_Id := Parent (N); + P : constant Node_Id := Parent (N); begin - return Nkind_In (P, N_Expanded_Name, - N_Generic_Association, - N_Parameter_Association, - N_Selected_Component) + return Nkind (P) in N_Expanded_Name + | N_Generic_Association + | N_Parameter_Association + | N_Selected_Component and then Selector_Name (P) = N; end; @@ -18604,7 +18705,7 @@ package body Sem_Util is function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is begin return - Ekind_In (Id, E_Protected_Type, E_Task_Type) + Ekind (Id) in E_Protected_Type | E_Task_Type and then Is_Single_Concurrent_Type_Declaration (Declaration_Node (Id)); end Is_Single_Concurrent_Type; @@ -18617,8 +18718,8 @@ package body Sem_Util is (N : Node_Id) return Boolean is begin - return Nkind_In (Original_Node (N), N_Single_Protected_Declaration, - N_Single_Task_Declaration); + return Nkind (Original_Node (N)) in + N_Single_Protected_Declaration | N_Single_Task_Declaration; end Is_Single_Concurrent_Type_Declaration; --------------------------------------------- @@ -18690,9 +18791,8 @@ package body Sem_Util is and then Is_Aliased (Entity (P_Ult)) and then Is_Formal (Entity (P_Ult)) and then Scope (Entity (P_Ult)) = Scop - and then Ekind_In (Scop, E_Function, - E_Operator, - E_Subprogram_Type) + and then Ekind (Scop) in + E_Function | E_Operator | E_Subprogram_Type and then Needs_Result_Accessibility_Level (Scop); end; end Is_Special_Aliased_Formal_Access; @@ -18729,30 +18829,31 @@ package body Sem_Util is or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; - ------------------------------------ - -- Is_Static_Expression_Function -- - ------------------------------------ + ------------------------ + -- Is_Static_Function -- + ------------------------ - function Is_Static_Expression_Function (Subp : Entity_Id) return Boolean is + function Is_Static_Function (Subp : Entity_Id) return Boolean is begin - return Is_Expression_Function (Subp) - and then Has_Aspect (Subp, Aspect_Static) + return Has_Aspect (Subp, Aspect_Static) and then (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) or else Is_True (Static_Boolean (Find_Value_Of_Aspect (Subp, Aspect_Static)))); - end Is_Static_Expression_Function; - - ----------------------------------------- - -- Is_Static_Expression_Function_Call -- - ----------------------------------------- + end Is_Static_Function; - function Is_Static_Expression_Function_Call (Call : Node_Id) return Boolean - is + ------------------------------ + -- Is_Static_Function_Call -- + ------------------------------ + function Is_Static_Function_Call (Call : Node_Id) return Boolean is function Has_All_Static_Actuals (Call : Node_Id) return Boolean; -- Return whether all actual parameters of Call are static expressions + ---------------------------- + -- Has_All_Static_Actuals -- + ---------------------------- + function Has_All_Static_Actuals (Call : Node_Id) return Boolean is Actual : Node_Id := First_Actual (Call); String_Result : constant Boolean := @@ -18765,12 +18866,12 @@ package body Sem_Util is -- ??? In the string-returning case we want to avoid a call -- being made to Establish_Transient_Scope in Resolve_Call, -- but at the point where that's tested for (which now includes - -- a call to test Is_Static_Expression_Function_Call), the - -- actuals of the call haven't been resolved, so expressions - -- of the actuals may not have been marked Is_Static_Expression - -- yet, so we force them to be resolved here, so we can tell if - -- they're static. Calling Resolve here is admittedly a kludge, - -- and we limit this call to string-returning cases. ??? + -- a call to test Is_Static_Function_Call), the actuals of the + -- call haven't been resolved, so expressions of the actuals + -- may not have been marked Is_Static_Expression yet, so we + -- force them to be resolved here, so we can tell if they're + -- static. Calling Resolve here is admittedly a kludge, and we + -- limit this call to string-returning cases. if String_Result then Resolve (Actual); @@ -18792,9 +18893,9 @@ package body Sem_Util is begin return Nkind (Call) = N_Function_Call and then Is_Entity_Name (Name (Call)) - and then Is_Static_Expression_Function (Entity (Name (Call))) + and then Is_Static_Function (Entity (Name (Call))) and then Has_All_Static_Actuals (Call); - end Is_Static_Expression_Function_Call; + end Is_Static_Function_Call; ---------------------------------------- -- Is_Subcomponent_Of_Atomic_Object -- @@ -18806,7 +18907,7 @@ package body Sem_Util is begin R := Get_Referenced_Object (N); - while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice) + while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice loop R := Get_Referenced_Object (Prefix (R)); @@ -19448,6 +19549,31 @@ package body Sem_Util is end if; end Is_Variable; + ------------------------ + -- Is_View_Conversion -- + ------------------------ + + function Is_View_Conversion (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Type_Conversion + and then Nkind (Unqual_Conv (N)) = N_Identifier + then + if Is_Tagged_Type (Etype (N)) + and then Is_Tagged_Type (Etype (Unqual_Conv (N))) + then + return True; + + elsif Is_Actual_Parameter (N) + and then (Is_Actual_Out_Parameter (N) + or else Is_Actual_In_Out_Parameter (N)) + then + return True; + end if; + end if; + + return False; + end Is_View_Conversion; + --------------------------- -- Is_Visibly_Controlled -- --------------------------- @@ -19505,7 +19631,7 @@ package body Sem_Util is function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is begin - pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function)); + pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function); -- A function declared within a protected type is volatile @@ -19636,8 +19762,8 @@ package body Sem_Util is begin pragma Assert (Is_Itype (Id)); return Present (Parent (Id)) - and then Nkind_In (Parent (Id), N_Full_Type_Declaration, - N_Subtype_Declaration) + and then Nkind (Parent (Id)) in + N_Full_Type_Declaration | N_Subtype_Declaration and then Defining_Entity (Parent (Id)) = Id; end Itype_Has_Declaration; @@ -20048,9 +20174,8 @@ package body Sem_Util is -- Obj := new ...'(new Coextension ...); if Nkind (Context_Nod) = N_Assignment_Statement then - Is_Dynamic := - Nkind_In (Expression (Context_Nod), N_Allocator, - N_Qualified_Expression); + Is_Dynamic := Nkind (Expression (Context_Nod)) in + N_Allocator | N_Qualified_Expression; -- An allocator that appears within the expression of a simple return -- statement is treated as a potentially dynamic coextension when the @@ -20060,10 +20185,8 @@ package body Sem_Util is -- return new ...'(new Coextension ...); elsif Nkind (Context_Nod) = N_Simple_Return_Statement then - Is_Dynamic := - Nkind_In (Expression (Context_Nod), N_Aggregate, - N_Allocator, - N_Qualified_Expression); + Is_Dynamic := Nkind (Expression (Context_Nod)) in + N_Aggregate | N_Allocator | N_Qualified_Expression; -- An alloctor that appears within the initialization expression of an -- object declaration is considered a potentially dynamic coextension @@ -20079,10 +20202,8 @@ package body Sem_Util is -- return Obj : ... := (new Coextension ...); elsif Nkind (Context_Nod) = N_Object_Declaration then - Is_Dynamic := - Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) - or else - Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; + Is_Dynamic := Nkind (Root_Nod) in N_Allocator | N_Qualified_Expression + or else Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; -- This routine should not be called with constructs that cannot contain -- coextensions. @@ -20248,12 +20369,12 @@ package body Sem_Util is -- suppressed. As a result the elaboration checks of the call must -- be disabled in order to preserve this dependency. - if Nkind_In (N, N_Entry_Call_Statement, - N_Function_Call, - N_Function_Instantiation, - N_Package_Instantiation, - N_Procedure_Call_Statement, - N_Procedure_Instantiation) + if Nkind (N) in N_Entry_Call_Statement + | N_Function_Call + | N_Function_Instantiation + | N_Package_Instantiation + | N_Procedure_Call_Statement + | N_Procedure_Instantiation then Nam := Extract_Name (N); @@ -20332,16 +20453,16 @@ package body Sem_Util is -- Obtain the complimentary unit of the main unit - if Nkind_In (Main_Unit, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Declaration) + if Nkind (Main_Unit) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Subprogram_Declaration then Aux_Id := Corresponding_Body (Main_Unit); - elsif Nkind_In (Main_Unit, N_Package_Body, - N_Subprogram_Body, - N_Subprogram_Renaming_Declaration) + elsif Nkind (Main_Unit) in N_Package_Body + | N_Subprogram_Body + | N_Subprogram_Renaming_Declaration then Aux_Id := Corresponding_Spec (Main_Unit); end if; @@ -20672,12 +20793,10 @@ package body Sem_Util is function Process (N : Node_Id) return Traverse_Result is begin - if Nkind_In (N, N_Procedure_Call_Statement, - N_Function_Call, - N_Raise_Statement, - N_Raise_Constraint_Error, - N_Raise_Program_Error, - N_Raise_Storage_Error) + if Nkind (N) in N_Procedure_Call_Statement + | N_Function_Call + | N_Raise_Statement + | N_Raise_xxx_Error then Result := True; return Abandon; @@ -21106,9 +21225,9 @@ package body Sem_Util is -- subprogram call, and the caller requests this behavior. elsif not Calls_OK - and then Nkind_In (Par, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + and then Nkind (Par) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then return False; @@ -21147,7 +21266,7 @@ package body Sem_Util is -- Only references warrant a marker - elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then + elsif Nkind (N) not in N_Expanded_Name | N_Identifier then return False; -- Only source references warrant a marker @@ -21303,17 +21422,17 @@ package body Sem_Util is Decl := Specification (Decl); end if; - if Nkind_In (Decl, N_Function_Instantiation, - N_Function_Specification, - N_Generic_Function_Renaming_Declaration, - N_Generic_Package_Renaming_Declaration, - N_Generic_Procedure_Renaming_Declaration, - N_Package_Body, - N_Package_Instantiation, - N_Package_Renaming_Declaration, - N_Package_Specification, - N_Procedure_Instantiation, - N_Procedure_Specification) + if Nkind (Decl) in N_Function_Instantiation + | N_Function_Specification + | N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + | N_Package_Body + | N_Package_Instantiation + | N_Package_Renaming_Declaration + | N_Package_Specification + | N_Procedure_Instantiation + | N_Procedure_Specification then Set_Chars (New_E, Chars (Defining_Unit_Name (Decl))); Set_Defining_Unit_Name (Decl, New_E); @@ -21770,15 +21889,15 @@ package body Sem_Util is function Has_More_Ids (N : Node_Id) return Boolean is begin - if Nkind_In (N, N_Component_Declaration, - N_Discriminant_Specification, - N_Exception_Declaration, - N_Formal_Object_Declaration, - N_Number_Declaration, - N_Object_Declaration, - N_Parameter_Specification, - N_Use_Package_Clause, - N_Use_Type_Clause) + if Nkind (N) in N_Component_Declaration + | N_Discriminant_Specification + | N_Exception_Declaration + | N_Formal_Object_Declaration + | N_Number_Declaration + | N_Object_Declaration + | N_Parameter_Specification + | N_Use_Package_Clause + | N_Use_Type_Clause then return More_Ids (N); else @@ -22019,9 +22138,9 @@ package body Sem_Util is -- Update the First/Next_Named_Association chain for a replicated -- call. - if Nkind_In (N, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (N) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then Update_Named_Associations (Old_Call => N, @@ -22443,12 +22562,9 @@ package body Sem_Util is -- an entity declaration that must be replaced when the expander is -- active if the expression has been preanalyzed or analyzed. - elsif not Ekind_In (Id, E_Block, - E_Constant, - E_Label, - E_Loop_Parameter, - E_Procedure, - E_Variable) + elsif Ekind (Id) not in + E_Block | E_Constant | E_Label | E_Loop_Parameter | + E_Procedure | E_Variable and then not Is_Type (Id) then return; @@ -22653,7 +22769,7 @@ package body Sem_Util is -- shared. Thus cloned_Subtype must be set to indicate the sharing. -- ??? What does this do? - if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then + if Ekind (Itype) in E_Class_Wide_Subtype | E_Record_Subtype then Set_Cloned_Subtype (New_Itype, Itype); end if; @@ -22741,9 +22857,9 @@ package body Sem_Util is EWA_Level := EWA_Level + 1; elsif EWA_Level > 0 - and then Nkind_In (N, N_Block_Statement, - N_Subprogram_Body, - N_Subprogram_Declaration) + and then Nkind (N) in N_Block_Statement + | N_Subprogram_Body + | N_Subprogram_Declaration then EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; end if; @@ -22769,9 +22885,9 @@ package body Sem_Util is Par_Nod => N); if EWA_Level > 0 - and then Nkind_In (N, N_Block_Statement, - N_Subprogram_Body, - N_Subprogram_Declaration) + and then Nkind (N) in N_Block_Statement + | N_Subprogram_Body + | N_Subprogram_Declaration then EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; @@ -23038,9 +23154,9 @@ package body Sem_Util is -- In case of a build-in-place call, the call will no longer be a -- call; it will have been rewritten. - if Nkind_In (Par, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (Par) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then return First_Named_Actual (Par); @@ -23353,7 +23469,7 @@ package body Sem_Util is function No_Heap_Finalization (Typ : Entity_Id) return Boolean is begin - if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) + if Ekind (Typ) in E_Access_Type | E_General_Access_Type and then Is_Library_Level_Entity (Typ) then -- A global No_Heap_Finalization pragma applies to all library-level @@ -23583,9 +23699,9 @@ package body Sem_Util is then if No (Actuals) and then - Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Function_Call, - N_Parameter_Association) + Nkind (Parent (N)) in N_Procedure_Call_Statement + | N_Function_Call + | N_Parameter_Association and then Ekind (S) /= E_Function then Set_Etype (N, Etype (S)); @@ -23737,15 +23853,13 @@ package body Sem_Util is end if; end; - elsif Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Exp) in N_Type_Conversion | N_Unchecked_Type_Conversion then Exp := Expression (Exp); goto Continue; - elsif Nkind_In (Exp, N_Slice, - N_Indexed_Component, - N_Selected_Component) + elsif Nkind (Exp) in + N_Slice | N_Indexed_Component | N_Selected_Component then -- Special check, if the prefix is an access type, then return -- since we are modifying the thing pointed to, not the prefix. @@ -23806,7 +23920,7 @@ package body Sem_Util is -- Follow renaming chain - if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) + if Ekind (Ent) in E_Variable | E_Constant and then Present (Renamed_Object (Ent)) then Exp := Renamed_Object (Ent); @@ -23829,8 +23943,8 @@ package body Sem_Util is -- a modification of the container. elsif Comes_From_Source (Original_Node (Exp)) - and then Nkind_In (Original_Node (Exp), N_Selected_Component, - N_Indexed_Component) + and then Nkind (Original_Node (Exp)) in + N_Selected_Component | N_Indexed_Component then Exp := Prefix (Original_Node (Exp)); goto Continue; @@ -23923,13 +24037,12 @@ package body Sem_Util is function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is begin - return - Nkind_In (Def, N_Access_Definition, - N_Access_Function_Definition, - N_Access_Procedure_Definition, - N_Access_To_Object_Definition, - N_Component_Definition, - N_Derived_Type_Definition) + return Nkind (Def) in N_Access_Definition + | N_Access_Function_Definition + | N_Access_Procedure_Definition + | N_Access_To_Object_Definition + | N_Component_Definition + | N_Derived_Type_Definition and then Null_Exclusion_Present (Def); end Is_Null_Excluding_Def; @@ -23951,12 +24064,12 @@ package body Sem_Util is if Is_Imported (Id) or else Is_Exported (Id) then return Unknown; - elsif Nkind_In (Decl, N_Component_Declaration, - N_Discriminant_Specification, - N_Formal_Object_Declaration, - N_Object_Declaration, - N_Object_Renaming_Declaration, - N_Parameter_Specification) + elsif Nkind (Decl) in N_Component_Declaration + | N_Discriminant_Specification + | N_Formal_Object_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration + | N_Parameter_Specification then -- A component declaration yields a non-null value when either -- its component definition or access definition carries a null @@ -24077,9 +24190,9 @@ package body Sem_Util is -- Taking the 'Access of something yields a non-null value elsif Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Access, - Name_Unchecked_Access, - Name_Unrestricted_Access) + and then Attribute_Name (N) in Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access then return Is_Non_Null; @@ -24123,7 +24236,8 @@ package body Sem_Util is if Nkind (N) = N_Null then return Present (Typ) and then Is_Descendant_Of_Address (Typ); - elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne) + elsif Nkind (N) in + N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne then declare L : constant Node_Id := Left_Opnd (N); @@ -24284,7 +24398,7 @@ package body Sem_Util is -- than the level of any visible named access type (see 3.10.2(21)). if Is_Type (E) then - return Type_Access_Level (E) + 1; + return Type_Access_Level (E) + 1; elsif Present (Renamed_Object (E)) then return Object_Access_Level (Renamed_Object (E)); @@ -24301,11 +24415,17 @@ package body Sem_Util is then return Type_Access_Level (Scope (E)) + 1; + -- An object of a named access type gets its level from its + -- associated type. + + elsif Is_Named_Access_Type (Etype (E)) then + return Type_Access_Level (Etype (E)); + else return Scope_Depth (Enclosing_Dynamic_Scope (E)); end if; - elsif Nkind_In (Orig_Obj, N_Indexed_Component, N_Selected_Component) then + elsif Nkind (Orig_Obj) in N_Indexed_Component | N_Selected_Component then Orig_Pre := Original_Node (Prefix (Orig_Obj)); if Is_Access_Type (Etype (Orig_Pre)) then @@ -24363,8 +24483,7 @@ package body Sem_Util is return Type_Access_Level (Etype (Prefix (Orig_Obj))); end if; - elsif Nkind_In (Orig_Obj, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Orig_Obj) in N_Type_Conversion | N_Unchecked_Type_Conversion then return Object_Access_Level (Expression (Orig_Obj)); @@ -24507,12 +24626,19 @@ package body Sem_Util is -- we are trying to implement here. elsif Nkind (Orig_Obj) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Orig_Obj), - Name_Old, - Name_Loop_Entry) + and then Attribute_Name (Orig_Obj) in Name_Old | Name_Loop_Entry then return Object_Access_Level (Current_Scope); + -- Move up the attribute reference when we encounter a 'Access variation + + elsif Nkind (Orig_Obj) = N_Attribute_Reference + and then Attribute_Name (Orig_Obj) in Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access + then + return Object_Access_Level (Prefix (Orig_Obj)); + -- Otherwise return the scope level of Standard. (If there are cases -- that fall through to this point they will be treated as having -- global accessibility for now. ???) @@ -24630,7 +24756,7 @@ package body Sem_Util is Item_Nam : Name_Id; begin - pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); + pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma); Item := N; @@ -24669,8 +24795,7 @@ package body Sem_Util is elsif Item_Nam = Name_Pre then Item_Nam := Name_uPre; - elsif Nam_In (Item_Nam, Name_Type_Invariant, - Name_Type_Invariant_Class) + elsif Item_Nam in Name_Type_Invariant | Name_Type_Invariant_Class then Item_Nam := Name_uType_Invariant; @@ -24778,7 +24903,7 @@ package body Sem_Util is -- The current Check_Policy pragma matches the requested policy or -- appears in the single argument form (Assertion, policy_id). - if Nam_In (Chars (Arg1), Name_Assertion, Policy) then + if Chars (Arg1) in Name_Assertion | Policy then return Chars (Arg2); end if; @@ -24825,7 +24950,7 @@ package body Sem_Util is -- assertions, unless they are disabled. Force Name_Check on -- ignored assertions. - if Nam_In (Kind, Name_Ignore, Name_Off) + if Kind in Name_Ignore | Name_Off and then (CodePeer_Mode or GNATprove_Mode) then Kind := Name_Check; @@ -25554,7 +25679,7 @@ package body Sem_Util is -- The entity denotes a primitive subprogram. Remove it from the list of -- primitives of the associated controlling type. - if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then + if Ekind (Id) in E_Function | E_Procedure and then Is_Primitive (Id) then Formal := First_Formal (Id); while Present (Formal) loop if Is_Controlling_Formal (Formal) then @@ -25849,7 +25974,7 @@ package body Sem_Util is while R_Scope /= Standard_Standard loop exit when R_Scope = E_Scope; - if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then + if Ekind (R_Scope) not in E_Package | E_Block | E_Loop then return False; else R_Scope := Scope (R_Scope); @@ -25963,7 +26088,7 @@ package body Sem_Util is EN2 : constant Entity_Id := Entity (N2); begin if Present (EN1) and then Present (EN2) - and then (Ekind_In (EN1, E_Variable, E_Constant) + and then (Ekind (EN1) in E_Variable | E_Constant or else Is_Formal (EN1)) and then EN1 = EN2 then @@ -26253,8 +26378,8 @@ package body Sem_Util is Typ : constant Entity_Id := Etype (E); begin - if Ekind_In (Typ, E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + if Ekind (Typ) in E_Anonymous_Access_Type + | E_Anonymous_Access_Subprogram_Type and then not Has_Convention_Pragma (Typ) then Basic_Set_Convention (Typ, Val); @@ -26722,8 +26847,8 @@ package body Sem_Util is if No (N) then return False; - elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, - N_If_Statement) + elsif Nkind (N) in + N_Handled_Sequence_Of_Statements | N_If_Statement then return True; end if; @@ -26749,8 +26874,8 @@ package body Sem_Util is -- never needs to be made public and furthermore, making it public can -- cause back end problems. - elsif Nkind_In (Parent (Id), N_Object_Declaration, - N_Function_Specification) + elsif Nkind (Parent (Id)) in + N_Object_Declaration | N_Function_Specification and then Within_HSS_Or_If (Id) then return; @@ -26782,7 +26907,7 @@ package body Sem_Util is begin -- Deal with indexed or selected component where prefix is modified - if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + if Nkind (N) in N_Indexed_Component | N_Selected_Component then Pref := Prefix (N); -- If prefix is access type, then it is the designated object that is @@ -26993,6 +27118,7 @@ package body Sem_Util is ----------------------------- -- Statically_Names_Object -- ----------------------------- + function Statically_Names_Object (N : Node_Id) return Boolean is begin if Statically_Denotes_Object (N) then @@ -27060,33 +27186,21 @@ package body Sem_Util is return False; end if; - if not Ekind_In (Entity (Selector_Name (N)), E_Component, - E_Discriminant) + if Ekind (Entity (Selector_Name (N))) not in + E_Component | E_Discriminant then return False; end if; + declare Comp : constant Entity_Id := Original_Record_Component (Entity (Selector_Name (N))); begin - -- In not calling Has_Discriminant_Dependent_Constraint here, - -- we are anticipating a language definition fixup. The - -- current definition of "statically names" includes the - -- wording "the selector_name names a component that does - -- not depend on a discriminant", which suggests that this - -- call should not be commented out. But it appears likely - -- that this wording will be updated to only apply to a - -- component declared in a variant part. There is no need - -- to disallow something like - -- with Post => ... and then - -- Some_Record.Some_Discrim_Dep_Array_Component'Old (I) - -- since the evaluation of the 'Old prefix cannot raise an - -- exception. If the language is not updated, then the call - -- below to H_D_C_C will need to be uncommented. - - if Is_Declared_Within_Variant (Comp) - -- or else Has_Discriminant_Dependent_Constraint (Comp) - then + -- AI12-0373 confirms that we should not call + -- Has_Discriminant_Dependent_Constraint here which would be + -- too strong. + + if Is_Declared_Within_Variant (Comp) then return False; end if; end; @@ -27171,7 +27285,7 @@ package body Sem_Util is -- 'Loop_Entry attribute into a conditional block. Infinite loops lack -- the conditional part. - if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) + if Nkind (Stmt) in N_Block_Statement | N_If_Statement and then Nkind (Original_Node (N)) = N_Loop_Statement then Stmt := Original_Node (N); @@ -27833,10 +27947,10 @@ package body Sem_Util is begin Pref := N; - while Nkind_In (Pref, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) + while Nkind (Pref) in N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + | N_Slice loop Pref := Prefix (Pref); end loop; @@ -28307,9 +28421,9 @@ package body Sem_Util is -- Recurse to handle unlikely case of multiple levels of qualification -- and/or conversion. - if Nkind_In (Expr, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind (Expr) in N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion then return Unqual_Conv (Expression (Expr)); @@ -28463,9 +28577,9 @@ package body Sem_Util is Par := N; while Present (Par) loop - if Nkind_In (Par, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (Par) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then return True; @@ -28539,8 +28653,8 @@ package body Sem_Util is if No (E) then return False; - elsif not Ekind_In (E, E_Discriminant, E_Component) - or else Nam_In (Chars (E), Name_uTag, Name_uParent) + elsif Ekind (E) not in E_Discriminant | E_Component + or else Chars (E) in Name_uTag | Name_uParent then Next_Entity (E); @@ -28595,12 +28709,12 @@ package body Sem_Util is then return; - -- In an instance, there is an ongoing problem with completion of + -- In an instance, there is an ongoing problem with completion of -- types derived from private types. Their structure is what Gigi - -- expects, but the Etype is the parent type rather than the - -- derived private type itself. Do not flag error in this case. The - -- private completion is an entity without a parent, like an Itype. - -- Similarly, full and partial views may be incorrect in the instance. + -- expects, but the Etype is the parent type rather than the derived + -- private type itself. Do not flag error in this case. The private + -- completion is an entity without a parent, like an Itype. Similarly, + -- full and partial views may be incorrect in the instance. -- There is no simple way to insure that it is consistent ??? -- A similar view discrepancy can happen in an inlined body, for the @@ -28694,7 +28808,7 @@ package body Sem_Util is elsif Is_Integer_Type (Expec_Type) and then Is_RTE (Found_Type, RE_Address) - and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract) + and then Nkind (Parent (Expr)) in N_Op_Add | N_Op_Subtract and then Expr = Left_Opnd (Parent (Expr)) and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) then @@ -28784,7 +28898,7 @@ package body Sem_Util is Error_Msg_N ("\\found package name!", Expr); elsif Is_Entity_Name (Expr) - and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure) + and then Ekind (Entity (Expr)) in E_Procedure | E_Generic_Procedure then if Ekind (Expec_Type) = E_Access_Subprogram_Type then Error_Msg_N @@ -28832,7 +28946,7 @@ package body Sem_Util is if Expec_Type = Standard_Boolean and then Is_Modular_Integer_Type (Found_Type) - and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) + and then Nkind (Parent (Expr)) in N_Op_And | N_Op_Or | N_Op_Xor and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare then declare @@ -28971,7 +29085,7 @@ package body Sem_Util is begin -- Integer and real literals are of a universal type - if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then + if Nkind (N) in N_Integer_Literal | N_Real_Literal then return True; -- The values of certain attributes are of a universal type diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 017a42a..e2147e0 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1228,6 +1228,12 @@ package Sem_Util is -- UFull_Typ - the underlying full view, if the full view is private -- CRec_Typ - the corresponding record type of the full views + function Get_Fullest_View + (E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id; + -- Get the fullest possible view of E, looking through private, + -- limited, packed array and other implementation types. If Include_PAT + -- is False, don't look inside packed array types. + function Has_Access_Values (T : Entity_Id) return Boolean; -- Returns true if type or subtype T is an access type, or has a component -- (at any recursive level) that is an access type. This is a conservative @@ -1589,6 +1595,10 @@ package Sem_Util is -- True if E is the constructed wrapper for an access_to_subprogram -- type with Pre/Postconditions. + function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean; + -- Determines if N is an actual parameter of in-out mode in a subprogram + -- call + function Is_Actual_Out_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter of out mode in a subprogram call @@ -1640,6 +1650,10 @@ package Sem_Util is -- True if T is a bounded string type. Used to make sure "=" composes -- properly for bounded string types. + function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean; + -- Determine whether entity Id denotes a procedure with synchronization + -- kind By_Protected_Procedure. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; -- Exp is the expression for an array bound. Determines whether the -- bound is a compile-time known value, or a constant entity, or an @@ -2081,13 +2095,13 @@ package Sem_Util is -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). -- Note that a label is *not* a statement, and will return False. - function Is_Static_Expression_Function (Subp : Entity_Id) return Boolean; - -- Determine whether subprogram Subp denotes a static expression function, - -- which is an expression function with the aspect Static with value True. + function Is_Static_Function (Subp : Entity_Id) return Boolean; + -- Determine whether subprogram Subp denotes a static function, + -- which is a function with the aspect Static with value True. - function Is_Static_Expression_Function_Call (Call : Node_Id) return Boolean; - -- Determine whether Call is a static call to a static expression function, - -- meaning that the name of the call denotes a static expression function + function Is_Static_Function_Call (Call : Node_Id) return Boolean; + -- Determine whether Call is a static call to a static function, + -- meaning that the name of the call denotes a static function -- and all of the call's actual parameters are given by static expressions. function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean; @@ -2184,6 +2198,12 @@ package Sem_Util is -- default is True since this routine is commonly invoked as part of the -- semantic analysis and it must not be disturbed by the rewriten nodes. + function Is_View_Conversion (N : Node_Id) return Boolean; + -- Returns True if N is a type_conversion whose operand is the name of an + -- object and both its target type and operand type are tagged, or it + -- appears in a call as an actual parameter of mode out or in out + -- (RM 4.6(5/2)). + function Is_Visibly_Controlled (T : Entity_Id) return Boolean; -- Check whether T is derived from a visibly controlled type. This is true -- if the root type is declared in Ada.Finalization. If T is derived diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 3c7f5d5..b67bb7d 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1165,7 +1165,7 @@ package body Sem_Warn is if Ekind (E1) = E_Variable or else - (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) + (Ekind (E1) in E_Out_Parameter | E_In_Out_Parameter and then not Is_Protected_Type (Current_Scope)) then -- If the formal has a class-wide type, retrieve its type @@ -1469,9 +1469,9 @@ package body Sem_Warn is UR := Original_Node (UR); loop - if Nkind_In (UR, N_Expression_With_Actions, - N_Qualified_Expression, - N_Type_Conversion) + if Nkind (UR) in N_Expression_With_Actions + | N_Qualified_Expression + | N_Type_Conversion then UR := Expression (UR); @@ -1612,9 +1612,9 @@ package body Sem_Warn is and then (Is_Object (E1) or else Is_Type (E1) or else Ekind (E1) = E_Label - or else Ekind_In (E1, E_Exception, - E_Named_Integer, - E_Named_Real) + or else Ekind (E1) in E_Exception + | E_Named_Integer + | E_Named_Real or else Is_Overloadable (E1) -- Package case, if the main unit is a package spec @@ -1895,7 +1895,7 @@ package body Sem_Warn is E : constant Entity_Id := Entity (N); begin - if Ekind_In (E, E_Variable, E_Out_Parameter) + if Ekind (E) in E_Variable | E_Out_Parameter and then Never_Set_In_Source_Check_Spec (E) and then not Has_Initial_Value (E) and then (No (Unset_Reference (E)) @@ -1975,10 +1975,11 @@ package body Sem_Warn is Nod := Parent (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma - and then Nam_In (Pragma_Name_Unmapped (Nod), - Name_Postcondition, - Name_Refined_Post, - Name_Contract_Cases) + and then + Pragma_Name_Unmapped (Nod) + in Name_Postcondition + | Name_Refined_Post + | Name_Contract_Cases then return True; @@ -2102,7 +2103,7 @@ package body Sem_Warn is P := Parent (P); exit when No (P); - if Nkind_In (P, N_If_Statement, N_Elsif_Part) + if Nkind (P) in N_If_Statement | N_Elsif_Part and then Ref_In (Condition (P)) then return; @@ -3188,7 +3189,7 @@ package body Sem_Warn is -- Reference to obsolescent component - elsif Ekind_In (E, E_Component, E_Discriminant) then + elsif Ekind (E) in E_Component | E_Discriminant then Error_Msg_NE ("??reference to obsolescent component& declared#", N, E); @@ -3567,8 +3568,9 @@ package body Sem_Warn is -- node, since assert pragmas get rewritten at analysis time. elsif Nkind (Original_Node (P)) = N_Pragma - and then Nam_In (Pragma_Name_Unmapped (Original_Node (P)), - Name_Assert, Name_Check) + and then + Pragma_Name_Unmapped (Original_Node (P)) + in Name_Assert | Name_Check then return; end if; @@ -4232,7 +4234,7 @@ package body Sem_Warn is -- Only process if warnings activated if Warn_On_Suspicious_Contract then - if Nkind_In (Par, N_Op_Eq, N_Op_Ne) then + if Nkind (Par) in N_Op_Eq | N_Op_Ne then if N = Left_Opnd (Par) then Arg := Right_Opnd (Par); else @@ -4422,10 +4424,10 @@ package body Sem_Warn is B : constant Node_Id := Parent (Parent (Scope (E))); S : Entity_Id := Empty; begin - if Nkind_In (B, - N_Expression_Function, - N_Subprogram_Body, - N_Subprogram_Renaming_Declaration) + if Nkind (B) in + N_Expression_Function | + N_Subprogram_Body | + N_Subprogram_Renaming_Declaration then S := Corresponding_Spec (B); end if; @@ -4587,10 +4589,10 @@ package body Sem_Warn is -- When we hit a package/subprogram body, issue warning and exit - elsif Nkind_In (P, N_Entry_Body, - N_Package_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Nkind (P) in N_Entry_Body + | N_Package_Body + | N_Subprogram_Body + | N_Task_Body then -- Case of assigned value never referenced @@ -4614,8 +4616,8 @@ package body Sem_Warn is -- Give appropriate message, distinguishing between -- assignment statements and out parameters. - if Nkind_In (Parent (LA), N_Parameter_Association, - N_Procedure_Call_Statement) + if Nkind (Parent (LA)) in N_Parameter_Association + | N_Procedure_Call_Statement then Error_Msg_NE ("?m?& modified by call, but value might not be " @@ -4641,8 +4643,8 @@ package body Sem_Warn is -- Give appropriate message, distinguishing between -- assignment statements and out parameters. - if Nkind_In (Parent (LA), N_Procedure_Call_Statement, - N_Parameter_Association) + if Nkind (Parent (LA)) in N_Procedure_Call_Statement + | N_Parameter_Association then Error_Msg_NE ("?m?& modified by call, but value overwritten #!", @@ -4673,10 +4675,10 @@ package body Sem_Warn is -- not generate the warning, since the variable in question -- may be accessed after an exception in the outer block. - if not Nkind_In (Parent (P), N_Entry_Body, - N_Package_Body, - N_Subprogram_Body, - N_Task_Body) + if Nkind (Parent (P)) not in N_Entry_Body + | N_Package_Body + | N_Subprogram_Body + | N_Task_Body then Set_Last_Assignment (Ent, Empty); return; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 9199af4..082f06f 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1278,6 +1278,7 @@ package body Sinfo is or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Iterated_Component_Association + or else NT (N).Nkind = N_Iterated_Element_Association or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition or else NT (N).Nkind = N_Number_Declaration @@ -2245,6 +2246,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Iterated_Component_Association + or else NT (N).Nkind = N_Iterated_Element_Association or else NT (N).Nkind = N_Iteration_Scheme or else NT (N).Nkind = N_Quantified_Expression); return Node2 (N); @@ -2258,6 +2260,14 @@ package body Sinfo is return Node1 (N); end Itype; + function Key_Expression + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iterated_Element_Association); + return Node1 (N); + end Key_Expression; + function Kill_Range_Check (N : Node_Id) return Boolean is begin @@ -2367,7 +2377,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Component_Association - or else NT (N).Nkind = N_Iterated_Component_Association); + or else NT (N).Nkind = N_Iterated_Component_Association + or else NT (N).Nkind = N_Iterated_Element_Association); return List5 (N); end Loop_Actions; @@ -2375,6 +2386,7 @@ package body Sinfo is (N : Node_Id) return Node_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Iterated_Element_Association or else NT (N).Nkind = N_Iteration_Scheme or else NT (N).Nkind = N_Quantified_Expression); return Node4 (N); @@ -4762,6 +4774,7 @@ package body Sinfo is or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Iterated_Component_Association + or else NT (N).Nkind = N_Iterated_Element_Association or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition or else NT (N).Nkind = N_Number_Declaration @@ -5733,6 +5746,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Iterated_Component_Association + or else NT (N).Nkind = N_Iterated_Element_Association or else NT (N).Nkind = N_Iteration_Scheme or else NT (N).Nkind = N_Quantified_Expression); Set_Node2_With_Parent (N, Val); @@ -5746,6 +5760,14 @@ package body Sinfo is Set_Node1 (N, Val); -- no parent, semantic field end Set_Itype; + procedure Set_Key_Expression + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iterated_Element_Association); + Set_Node1_With_Parent (N, Val); + end Set_Key_Expression; + procedure Set_Kill_Range_Check (N : Node_Id; Val : Boolean := True) is begin @@ -5855,7 +5877,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Component_Association - or else NT (N).Nkind = N_Iterated_Component_Association); + or else NT (N).Nkind = N_Iterated_Component_Association + or else NT (N).Nkind = N_Iterated_Element_Association); Set_List5 (N, Val); -- semantic field, no parent set end Set_Loop_Actions; @@ -5863,6 +5886,7 @@ package body Sinfo is (N : Node_Id; Val : Node_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Iterated_Element_Association or else NT (N).Nkind = N_Iteration_Scheme or else NT (N).Nkind = N_Quantified_Expression); Set_Node4_With_Parent (N, Val); @@ -7099,240 +7123,6 @@ package body Sinfo is UI_From_Int (Int (S) - Int (Sloc (N)))); end Set_End_Location; - -------------- - -- Nkind_In -- - -------------- - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9 or else - T = V10; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind; - V11 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9 or else - T = V10 or else - T = V11; - end Nkind_In; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind; - V11 : Node_Kind; - V12 : Node_Kind; - V13 : Node_Kind; - V14 : Node_Kind; - V15 : Node_Kind; - V16 : Node_Kind; - V17 : Node_Kind) return Boolean - is - begin - return T = V1 or else - T = V2 or else - T = V3 or else - T = V4 or else - T = V5 or else - T = V6 or else - T = V7 or else - T = V8 or else - T = V9 or else - T = V10 or else - T = V11 or else - T = V12 or else - T = V13 or else - T = V14 or else - T = V15 or else - T = V16 or else - T = V17; - end Nkind_In; - -------------------------- -- Pragma_Name_Unmapped -- -------------------------- diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 9ae8ce7..2583f91 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4241,6 +4241,26 @@ package Sinfo is -- Component_Associations (List2) -- Etype (Node5-Sem) + --------------------------------- + -- 3.4.5 Comtainer_Aggregates -- + --------------------------------- + + -- N_Iterated_Element_Association + -- Key_Expression (Node1) + -- Iterator_Specification (Node2) + -- Expression (Node3) + -- Loop_Parameter_Specification (Node4) + -- Loop_Actions (List5-Sem) + + -- Exactly one of Iterator_Specification or Loop_Parameter_ + -- specification is present. If the Key_Expression is absent, + -- the construct is parsed as an Iterated_Component_Association, + -- and legality checks are performed during semantic analysis. + + -- Both iterated associations are Ada2020 features that are + -- expanded during aggregate construction, and do not appear in + -- expanded code. + -------------------------------------------------- -- 4.4 Expression/Relation/Term/Factor/Primary -- -------------------------------------------------- @@ -8917,6 +8937,7 @@ package Sinfo is N_Handled_Sequence_Of_Statements, N_Index_Or_Discriminant_Constraint, N_Iterated_Component_Association, + N_Iterated_Element_Association, N_Itype_Reference, N_Label, N_Modular_Type_Definition, @@ -9842,6 +9863,9 @@ package Sinfo is function Itype (N : Node_Id) return Entity_Id; -- Node1 + function Key_Expression + (N : Node_Id) return Node_Id; -- Node1 + function Kill_Range_Check (N : Node_Id) return Boolean; -- Flag11 @@ -10951,6 +10975,9 @@ package Sinfo is procedure Set_Itype (N : Node_Id; Val : Entity_Id); -- Node1 + procedure Set_Key_Expression + (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Kill_Range_Check (N : Node_Id; Val : Boolean := True); -- Flag11 @@ -11383,136 +11410,6 @@ package Sinfo is -- for the argument. This is Arg itself, or, in the case where Arg is a -- pragma argument association node, the expression from this node. - -------------------------------- - -- Node_Kind Membership Tests -- - -------------------------------- - - -- The following functions allow a convenient notation for testing whether - -- a Node_Kind value matches any one of a list of possible values. In each - -- case True is returned if the given T argument is equal to any of the V - -- arguments. Note that there is a similar set of functions defined in - -- Atree where the first argument is a Node_Id whose Nkind field is tested. - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind) return Boolean; - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind; - V11 : Node_Kind) return Boolean; - - -- 12..16-parameter versions are not yet needed - - function Nkind_In - (T : Node_Kind; - V1 : Node_Kind; - V2 : Node_Kind; - V3 : Node_Kind; - V4 : Node_Kind; - V5 : Node_Kind; - V6 : Node_Kind; - V7 : Node_Kind; - V8 : Node_Kind; - V9 : Node_Kind; - V10 : Node_Kind; - V11 : Node_Kind; - V12 : Node_Kind; - V13 : Node_Kind; - V14 : Node_Kind; - V15 : Node_Kind; - V16 : Node_Kind; - V17 : Node_Kind) return Boolean; - - pragma Inline (Nkind_In); - -- Inline all above functions - ----------------------- -- Utility Functions -- ----------------------- @@ -11901,6 +11798,13 @@ package Sinfo is 4 => True, -- Discrete_Choices (List4) 5 => True), -- Loop_Actions (List5-Sem); + N_Iterated_Element_Association => + (1 => True, -- Key_expression + 2 => True, -- Iterator_Specification + 3 => True, -- Expression (Node3) + 4 => True, -- Loop_Parameter_Specification + 5 => True), -- Loop_Actions (List5-Sem); + N_Delta_Aggregate => (1 => False, -- Unused 2 => True, -- Component_Associations (List2) @@ -13446,6 +13350,7 @@ package Sinfo is pragma Inline (Iterator_Filter); pragma Inline (Iteration_Scheme); pragma Inline (Itype); + pragma Inline (Key_Expression); pragma Inline (Kill_Range_Check); pragma Inline (Last_Bit); pragma Inline (Last_Name); @@ -13812,6 +13717,7 @@ package Sinfo is pragma Inline (Set_Iteration_Scheme); pragma Inline (Set_Iterator_Specification); pragma Inline (Set_Itype); + pragma Inline (Set_Key_Expression); pragma Inline (Set_Kill_Range_Check); pragma Inline (Set_Label_Construct); pragma Inline (Set_Last_Bit); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index c4486ff..6310442 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -514,6 +514,8 @@ package Snames is Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT + Name_CUDA_Execute : constant Name_Id := N + $; -- GNAT + Name_CUDA_Global : constant Name_Id := N + $; -- GNAT -- Note: CPU is not in this list because its name matches the name of -- the corresponding attribute. However, it is included in the definition @@ -1998,6 +2000,8 @@ package Snames is Pragma_CPP_Constructor, Pragma_CPP_Virtual, Pragma_CPP_Vtable, + Pragma_CUDA_Execute, + Pragma_CUDA_Global, Pragma_Deadline_Floor, Pragma_Debug, Pragma_Default_Initial_Condition, diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 8fc91fd..3aeb95f 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -532,7 +532,7 @@ package body Sprint is -- We do not know the actual end location in the generated code and -- it could be much closer than in the source code, so play safe. - if Nkind_In (Dump_Node, N_Case_Statement, N_If_Statement) then + if Nkind (Dump_Node) in N_Case_Statement | N_If_Statement then Set_End_Location (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); end if; @@ -1325,6 +1325,22 @@ package body Sprint is Write_Str (" => "); Sprint_Node (Expression (Node)); + when N_Iterated_Element_Association => + Set_Debug_Sloc; + if Present (Iterator_Specification (Node)) then + Sprint_Node (Iterator_Specification (Node)); + else + Sprint_Node (Loop_Parameter_Specification (Node)); + end if; + + if Present (Key_Expression (Node)) then + Write_Str (" use "); + Sprint_Node (Key_Expression (Node)); + end if; + + Write_Str (" => "); + Sprint_Node (Expression (Node)); + when N_Component_Clause => Write_Indent; Sprint_Node (Component_Name (Node)); @@ -3521,8 +3537,8 @@ package body Sprint is -- where the aspects are printed inside the package specification. if Has_Aspects (Node) - and then not Nkind_In (Node, N_Generic_Package_Declaration, - N_Package_Declaration) + and then Nkind (Node) not in + N_Generic_Package_Declaration | N_Package_Declaration and then not Is_Empty_List (Aspect_Specifications (Node)) then Sprint_Aspect_Specifications (Node, Semicolon => True); @@ -4729,9 +4745,7 @@ package body Sprint is -- See if we have extra formals - if Nkind_In (N, N_Function_Specification, - N_Procedure_Specification) - then + if Nkind (N) in N_Function_Specification | N_Procedure_Specification then Ent := Defining_Entity (N); -- Loop to write extra formals (if any) diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index f3f7eb5..57b4d55 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -61,6 +61,7 @@ package Stand is S_Integer, S_Long_Integer, S_Long_Long_Integer, + S_Long_Long_Long_Integer, S_Natural, S_Positive, @@ -283,6 +284,9 @@ package Stand is Standard_Long_Integer : Entity_Id renames SE (S_Long_Integer); Standard_Long_Long_Integer : Entity_Id renames SE (S_Long_Long_Integer); + Standard_Long_Long_Long_Integer : Entity_Id renames + SE (S_Long_Long_Long_Integer); + Standard_Op_Add : Entity_Id renames SE (S_Op_Add); Standard_Op_And : Entity_Id renames SE (S_Op_And); Standard_Op_Concat : Entity_Id renames SE (S_Op_Concat); diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index b90af84..565c41a 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -207,13 +207,13 @@ package body Styleg is function OK_Boolean_Operand (N : Node_Id) return Boolean is begin - if Nkind_In (N, N_Identifier, N_Expanded_Name) then + if Nkind (N) in N_Identifier | N_Expanded_Name then return True; elsif Nkind (N) = N_Op_Not then return OK_Boolean_Operand (Original_Node (Right_Opnd (N))); - elsif Nkind_In (N, N_Op_And, N_Op_Or) then + elsif Nkind (N) in N_Op_And | N_Op_Or then return OK_Boolean_Operand (Original_Node (Left_Opnd (N))) and then OK_Boolean_Operand (Original_Node (Right_Opnd (N))); @@ -233,7 +233,7 @@ package body Styleg is Orig : constant Node_Id := Original_Node (Node); begin - if Nkind_In (Orig, N_Op_And, N_Op_Or) then + if Nkind (Orig) in N_Op_And | N_Op_Or then declare L : constant Node_Id := Original_Node (Left_Opnd (Orig)); R : constant Node_Id := Original_Node (Right_Opnd (Orig)); diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb index cd5f535..5da63eb 100644 --- a/gcc/ada/switch.adb +++ b/gcc/ada/switch.adb @@ -165,10 +165,7 @@ package body Switch is (Switch_Chars (First .. Last) = "-param" or else Switch_Chars (First .. Last) = "dumpdir" or else Switch_Chars (First .. Last) = "dumpbase" or else - Switch_Chars (First .. Last) = "dumpbase-ext" or else - -- Can we remove auxbase-strip and auxbase already? - Switch_Chars (First .. Last) = "auxbase-strip" or else - Switch_Chars (First .. Last) = "auxbase"); + Switch_Chars (First .. Last) = "dumpbase-ext"); end Is_Internal_GCC_Switch; --------------- diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 140cb21..3b33ee7 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -175,8 +175,8 @@ package body Tbuild is Attribute_Name => Attribute_Name); begin - pragma Assert (Nam_In (Attribute_Name, Name_Address, - Name_Unrestricted_Access)); + pragma Assert + (Attribute_Name in Name_Address | Name_Unrestricted_Access); Set_Must_Be_Byte_Aligned (N, True); return N; end Make_Byte_Aligned_Attribute_Reference; @@ -352,6 +352,7 @@ package body Tbuild is Check_Restriction (No_Implicit_Loops, Node); if Present (Iteration_Scheme) + and then Nkind (Iteration_Scheme) /= N_Iterator_Specification and then Present (Condition (Iteration_Scheme)) then Check_Restriction (No_Implicit_Conditionals, Node); @@ -796,6 +797,23 @@ package body Tbuild is return Result; end OK_Convert_To; + -------------- + -- Sel_Comp -- + -------------- + + function Sel_Comp (Pre : Node_Id; Sel : String) return Node_Id is + begin + return Make_Selected_Component + (Sloc => Sloc (Pre), + Prefix => Pre, + Selector_Name => Make_Identifier (Sloc (Pre), Name_Find (Sel))); + end Sel_Comp; + + function Sel_Comp (Pre, Sel : String; Loc : Source_Ptr) return Node_Id is + begin + return Sel_Comp (Make_Identifier (Loc, Name_Find (Pre)), Sel); + end Sel_Comp; + ------------- -- Set_NOD -- ------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 3256804..70bf653 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -335,6 +335,11 @@ package Tbuild is -- fixed-point small is called typ_SMALL where typ is the name of the -- fixed-point type (as passed in Related_Id), and Suffix is "SMALL". + function Sel_Comp (Pre, Sel : String; Loc : Source_Ptr) return Node_Id; + function Sel_Comp (Pre : Node_Id; Sel : String) return Node_Id; + -- Create a selected component of the form Pre.Sel; that is, Pre is the + -- prefix, and Sel is the selector name. + function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; -- Like Convert_To, except that a conversion node is always generated, and -- the Conversion_OK flag is set on this conversion node. diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index b4fd545..e76b138 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -1274,7 +1274,7 @@ package body Treepr is -- Special case End_Span = Uint5 when F_Field5 => - if Nkind_In (N, N_Case_Statement, N_If_Statement) then + if Nkind (N) in N_Case_Statement | N_If_Statement then Print_End_Span (N); else Print_Field (Field5 (N), Fmt); |