diff options
468 files changed, 16338 insertions, 19118 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 74490c4..7941616 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,344 @@ +2025-06-05 Jeff Law <jlaw@ventanamicro.com> + + * config/riscv/riscv.cc (riscv_expand_conditional_move): Avoid + zicond in some cases involving sign bit tests. + * config/riscv/riscv.md: Split a splat of the sign bit feeding a + masking off high bits into a pair of right shifts. + +2025-06-05 Uros Bizjak <ubizjak@gmail.com> + + PR target/120553 + * config/i386/i386.md (mov<mode>cc): Use "general_operand" + predicate for operands 2 and 3 for all modes. + +2025-06-05 Marek Polacek <polacek@redhat.com> + + * doc/invoke.texi: Update a link to c99status.html. + * doc/standards.texi: Likewise. + +2025-06-05 Andrew Pinski <quic_apinski@quicinc.com> + + * tree-ssa-ccp.cc (insert_clobber_before_stack_restore): Update the virtual + op on the inserted clobber and the stack restore function. + (do_ssa_ccp): Don't add TODO_update_ssa to the todo. + +2025-06-05 Andrew Pinski <quic_apinski@quicinc.com> + + * config/aarch64/aarch64-sve-builtins.cc: Include value-range.h and tree-ssanames.h + (gimple_folder::convert_and_fold): Use make_ssa_name + instead of create_tmp_var for the temporary. Add comment about callback argument. + +2025-06-05 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/120231 + * range-op.cc (range_op_table::range_op_table): Register op_cast + also for FLOAT_EXPR and FIX_TRUNC_EXPR. + (RO_III): Adjust comment. + (range_op_handler::op1_range): Handle RO_IFI rather than RO_IFF. + Don't handle RO_FII. + (range_operator::op1_range): Remove overload with + irange &, tree, const frange &, const frange &, relation_trio + and frange &, tree, const irange &, const irange &, relation_trio + arguments. Add overload with + irange &, tree, const frange &, const irange &, relation_trio + arguments. + * range-op-mixed.h (operator_cast::op1_range): Remove overload with + irange &, tree, const frange &, const frange &, relation_trio + and frange &, tree, const irange &, const irange &, relation_trio + arguments. Add overload with + irange &, tree, const frange &, const irange &, relation_trio and + frange &, tree, const irange &, const frange &, relation_trio + arguments. + * range-op.h (range_operator::op1_cast): Remove overload with + irange &, tree, const frange &, const frange &, relation_trio + and frange &, tree, const irange &, const irange &, relation_trio + arguments. Add overload with + irange &, tree, const frange &, const irange &, relation_trio + arguments. + * range-op-float.cc (operator_cast::fold_range): Implement + float to int and int to float casts. + (operator_cast::op1_range): Remove overload with + irange &, tree, const frange &, const frange &, relation_trio + and frange &, tree, const irange &, const irange &, relation_trio + arguments. Add overload with + irange &, tree, const frange &, const irange &, relation_trio and + frange &, tree, const irange &, const frange &, relation_trio + arguments and implement reverse op of float to int and int to float + cast there. + +2025-06-05 Jan Hubicka <hubicka@ucw.cz> + + * auto-profile.cc (afdo_calculate_branch_prob): Fix typo + in previous patch. + +2025-06-05 Kito Cheng <kito.cheng@sifive.com> + + * common/config/riscv/riscv-common.cc: Remove structured binding + from the code. + +2025-06-05 Jakub Jelinek <jakub@redhat.com> + + PR middle-end/120547 + * real.cc (real_from_integer): Remove maxbitlen variable, use + len instead of that. When shifting right, or in 1 if any of the + shifted away bits are non-zero. Formatting fix. + +2025-06-05 Jan Hubicka <hubicka@ucw.cz> + + * auto-profile.cc (update_count_by_afdo_count): Fix handling + of GUESSED_LOCAL. + (afdo_calculate_branch_prob): Preserve static profile for + probabilities 0 and 1. + +2025-06-05 Pan Li <pan2.li@intel.com> + + * config/riscv/autovec-opt.md: Leverage vdup_v and v_vdup + binary op for different patterns. + * config/riscv/vector-iterators.md: Add vdup_v and v_vdup + binary op iterators. + +2025-06-05 Jeff Law <jlaw@ventanamicro.com> + + * config/riscv/zicond.md: Add new splitters to select + 1, -1 or -1, 1 based on a sign bit test. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension definition. + * config/riscv/riscv-ext.opt: New extension mask. + * doc/riscv-ext.texi: Document the new extension. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension definition. + * config/riscv/riscv-ext.opt: New extension mask. + * doc/riscv-ext.texi: Document the new extension. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension definition. + * config/riscv/riscv-ext.opt: New extension mask. + * doc/riscv-ext.texi: Document the new extension. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension definition. + * config/riscv/riscv-ext.opt: New extension mask. + * doc/riscv-ext.texi: Document the new extension. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension definition. + * config/riscv/riscv-ext.opt: New extension mask. + * doc/riscv-ext.texi: Document the new extension. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension definition. + * config/riscv/riscv-ext.opt: New extension mask. + * doc/riscv-ext.texi: Document the new extension. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension definition. + * config/riscv/riscv-ext.opt: New extension mask. + * doc/riscv-ext.texi: Document the new extension. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * tree-vect-data-refs.cc (vect_can_force_dr_alignment_p): Return + false if the variable has no symtab node. + +2025-06-05 Spencer Abson <spencer.abson@arm.com> + + * tree-eh.cc (operation_could_trap_helper_p): Cover FIX_TRUNC + expressions explicitly. + +2025-06-05 Tobias Burnus <tburnus@baylibre.com> + + * config.gcc (--with-{arch,tune}): Use .def file to validate gcn + processor names. + * doc/install.texi (amdgcn*-*-*): Update list of devices supported + by --with-arch/--with-tune. + +2025-06-05 Hongyu Wang <hongyu.wang@intel.com> + + PR middle-end/112824 + * tree-sra.cc (sra_get_max_scalarization_size): Use MOVE_MAX + instead of UNITS_PER_WORD to define max_scalarization_size. + +2025-06-05 Hu, Lin1 <lin1.hu@intel.com> + + * config/i386/sse.md + (avx512f_movddup512<mask_name>): Change sselog1 to ssemov. + (avx_movddup256<mask_name>): Ditto. + (*vec_dupv2di): Change alternative 4's type attribute from sselog1 + to ssemov. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: Update declaration. + +2025-06-04 Kugan Vivekanandarajah <kvivekananda@nvidia.com> + + * auto-profile.cc (autofdo_source_profile::read): Dump message + while merging profile. + * pass_manager.h (get_pass_auto_profile): New. + +2025-06-04 Sandra Loosemore <sloosemore@baylibre.com> + + PR c++/120518 + * omp-general.cc (omp_device_num_check): Look inside a + CLEANUP_POINT_EXPR when trying to optimize special cases. + +2025-06-04 Thomas Schwinge <tschwinge@baylibre.com> + + * config/nvptx/mkoffload.cc (process): Use an 'auto_vec' for + 'file_idx'. + +2025-06-04 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/14295 + PR tree-optimization/108358 + PR tree-optimization/114169 + * tree-ssa-forwprop.cc (optimize_agr_copyprop): New function. + (pass_forwprop::execute): Call optimize_agr_copyprop for load/store statements. + +2025-06-04 Pengfei Li <Pengfei.Li2@arm.com> + + * match.pd: Add folding rule for vector average. + * tree-ssa-ccp.cc (get_default_value): Reject vector types. + (evaluate_stmt): Reject vector types. + * tree-ssanames.cc (get_nonzero_bits_1): Extend to handle + uniform vectors. + +2025-06-04 Xi Ruoyao <xry111@xry111.site> + + PR rtl-optimization/120050 + * ext-dce.cc (ext_dce_process_uses): Break early if a SUBREG in + rhs is promoted and the truncation from the inner mode to the + outer mode is not a noop when handling SETs. + +2025-06-04 Jakub Jelinek <jakub@redhat.com> + + * range-op-float.cc (range_operator::fold_range, + range_operator::op1_range, range_operator::op2_range, + range_operator::lhs_op1_relation, range_operator::lhs_op2_relation, + operator_equal::op1_range, foperator_unordered_gt::op1_range): Fix + up parameter indentation. + * range-op.cc (range_operator::fold_range, range_operator::op1_range, + range_operator::op1_op2_relation_effect, + range_operator::update_bitmask, plus_minus_ranges, + operator_bitwise_and::lhs_op1_relation): Likewise. + +2025-06-04 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/120231 + * range-op-mixed.h (operator_cast::fold_range): Add overload + with 3 {,const} frange & operands. Change parameter names and + add final override keywords for float <-> integer cast overloads. + (operator_cast::op1_range): Likewise. + * range-op-float.cc (operator_cast::fold_range): New overload + with 3 {,const} frange & operands. + (operator_cast::op1_range): Likewise. + +2025-06-04 Dongyan Chen <chendongyan@isrc.iscas.ac.cn> + + * config/riscv/riscv-ext.def: Imply zicsr. + +2025-06-04 Dongyan Chen <chendongyan@isrc.iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension defs. + * config/riscv/riscv-ext.opt: Ditto. + * doc/riscv-ext.texi: Ditto. + +2025-06-04 Richard Sandiford <richard.sandiford@arm.com> + + PR rtl-optimization/120447 + * emit-rtl.cc (validate_subreg): Restrict ordered_p test + between osize and regsize to cases where the inner value + occupies multiple blocks. + +2025-06-04 Pan Li <pan2.li@intel.com> + + * config/riscv/riscv.cc (get_vector_binary_rtx_cost): Rename + the args to scalar2vr. + (riscv_rtx_costs): Leverage above func to avoid code dup. + +2025-06-04 H.J. Lu <hjl.tools@gmail.com> + + PR debug/120525 + * var-tracking.cc (prepare_call_arguments): Use MEM_EXPR only + if MEM_P is true. + +2025-06-04 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension defs. + * config/riscv/riscv-ext.opt: Ditto. + * doc/riscv-ext.texi: Ditto. + +2025-06-04 Hu, Lin1 <lin1.hu@intel.com> + + * config/i386/i386.md (define_peephole2): Define some new peephole2 for + APX NDD. + +2025-06-04 Hu, Lin1 <lin1.hu@intel.com> + + * config/i386/i386.md: Add 4 new peephole2 by swap the original + peephole2's operands' order to support new pattern. + +2025-06-04 H.J. Lu <hjl.tools@gmail.com> + + PR other/120494 + * calls.cc (expand_call): Always add REG_CALL_DECL note. + (emit_library_call_value_1): Likewise. + +2025-06-03 Richard Biener <rguenther@suse.de> + + * gimple-fold.cc (create_tmp_reg_or_ssa_name): Always + create a SSA name. + +2025-06-03 Pan Li <pan2.li@intel.com> + + * config/riscv/riscv-v.cc (expand_vx_binary_vec_vec_dup): Add new + case for DIV op. + * config/riscv/riscv.cc (get_vector_binary_rtx_cost): Add new func + to get the cost of vector binary. + (riscv_rtx_costs): Add div rtx match and leverage above wrap to + get cost. + * config/riscv/vector-iterators.md: Add new op div to no_shift_vx_op. + +2025-06-03 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120517 + * tree-vect-data-refs.cc (vect_analyze_data_ref_accesses): + Fix math in dataref group split. + +2025-06-03 Paul-Antoine Arras <parras@baylibre.com> + + * config/riscv/riscv-vector-costs.cc (costs::adjust_stmt_cost): Replace + FR2VR with get_fr2vr_cost (). + * config/riscv/riscv.cc (riscv_register_move_cost): Likewise. + (riscv_builtin_vectorization_cost): Likewise. + +2025-06-03 Paul-Antoine Arras <parras@baylibre.com> + + PR target/119100 + * config/riscv/autovec-opt.md (*<optab>_vf_<mode>): Add new pattern to + combine vec_duplicate + vfm{add,sub}.vv into vfm{add,sub}.vf. + * config/riscv/riscv-opts.h (FPR2VR_COST_UNPROVIDED): Define. + * config/riscv/riscv-protos.h (get_fr2vr_cost): Declare function. + * config/riscv/riscv.cc (riscv_rtx_costs): Add cost model for MULT with + VEC_DUPLICATE. + (get_fr2vr_cost): New function. + * config/riscv/riscv.opt: Add new option --param=fpr2vr-cost. + +2025-06-03 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/120451 + * tree-switch-conversion.cc (switch_conversion::build_one_array): Mark + the newly created decl as mergable. + 2025-06-02 Alexandre Oliva <oliva@adacore.com> PR rtl-optimization/120424 diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 42c5479..c6de4e3 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20250603 +20250606 diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 55c8f74..7ef50ea 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,374 @@ +2025-06-05 squirek <squirek@adacore.com> + + * sem_warn.adb + (Warn_On_Useless_Assignment): Disable out value "overwritten" warning + when we are not warning on unread out parameters (e.g. "-gnatw.o"). + +2025-06-05 Tonu Naks <naks@adacore.com> + + * libgnat/i-cstrin.adb: null pointer check in Update + +2025-06-05 Arnaud Charlet <charlet@adacore.com> + + * exp_util.adb, rtsfind.adb, rtsfind.ads, sem_prag.adb: Remove + references to RO_GH_Big_Integer and + Ada_Numerics_Big_Numbers_Big_Integers_Ghost. + * libgnat/a-strfix.adb, libgnat/a-strmap.adb, + libgnat/a-strsea.adb, libgnat/a-strsup.adb, + libgnat/i-c.ads, libgnat/i-c.adb, libgnat/s-aridou.adb, + libgnat/s-aridou.ads, libgnat/s-arit128.adb, + libgnat/s-arit128.ads, libgnat/s-arit32.adb, + libgnat/s-arit32.ads, libgnat/s-arit64.adb, + libgnat/s-arit64.ads, libgnat/s-casuti.adb, + libgnat/s-exnint.ads, libgnat/s-exnlli.ads, + libgnat/s-exnllli.ads, libgnat/s-expint.ads, + libgnat/s-explli.ads, libgnat/s-expllli.ads, + libgnat/s-explllu.ads, libgnat/s-expllu.ads, + libgnat/s-expmod.adb, libgnat/s-expmod.ads, + libgnat/s-exponn.adb, libgnat/s-exponn.ads, + libgnat/s-expont.adb, libgnat/s-expont.ads, + libgnat/s-exponu.adb, libgnat/s-exponu.ads, + libgnat/s-imaged.ads, libgnat/s-imaged.adb, + libgnat/s-expuns.ads, libgnat/s-imagef.ads, + libgnat/s-imagef.adb, libgnat/s-imagei.adb, + libgnat/s-imagei.ads, libgnat/s-imageu.adb, + libgnat/s-imageu.ads, libgnat/s-imgboo.adb, + libgnat/s-imde128.ads, libgnat/s-imde32.ads, + libgnat/s-imde64.ads, libgnat/s-imfi128.ads, + libgnat/s-imfi32.ads, libgnat/s-imfi64.ads, + libgnat/s-imgboo.ads, libgnat/s-imgint.ads, + libgnat/s-imglli.ads, libgnat/s-imgllli.ads, + libgnat/s-imglllu.ads, libgnat/s-imgllu.ads, + libgnat/s-imguns.ads, libgnat/s-valboo.adb, + libgnat/s-valboo.ads, libgnat/s-valint.ads, + libgnat/s-vallli.ads, libgnat/s-valllli.ads, + libgnat/s-vallllu.ads, libgnat/s-valllu.ads, + libgnat/s-valuns.ads, libgnat/s-valuti.adb, + libgnat/s-valuti.ads, libgnat/s-valuei.adb, + libgnat/s-valuei.ads, libgnat/s-valueu.ads, + libgnat/s-valueu.adb, libgnat/s-veboop.adb, + libgnat/s-veboop.ads, libgnat/s-widint.ads, + libgnat/s-widlli.ads, libgnat/s-widllli.ads, + libgnat/s-widlllu.ads, libgnat/s-widllu.ads, + libgnat/s-widthi.adb, libgnat/s-widthu.adb, + libgnat/s-widthu.ads, libgnat/s-widuns.ads: Remove ghost code + and SPARK annotations. + * libgnat/a-nbnbig.ads, libgnat/a-nbnbig.adb, + libgnat/s-spark.ads, libgnat/s-spcuop.adb, + libgnat/s-spcuop.ads, libgnat/s-vaispe.adb, + libgnat/s-vaispe.ads, libgnat/s-vauspe.adb, + libgnat/s-vauspe.ads, libgnat/s-vs_int.ads, + libgnat/s-vs_lli.ads, libgnat/s-vs_llu.ads, + libgnat/s-vs_uns.ads, libgnat/s-valspe.adb, + libgnat/s-valspe.ads, libgnat/s-vsllli.ads, + libgnat/s-vslllu.ads: Removed. + * Makefile.rtl: Update list of runtime units. + * gcc-interface/Make-lang.in: Remove object files. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * fname-uf.adb: Fix documentation comment. + (Get_Default_File_Name): Fix indices of default patterns. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * atree.ads (New_Copy, Relocate_Node): Tweak documentation comments. + +2025-06-05 Andres Toom <toom@adacore.com> + + * libgnat/a-nudira.ads: Activate SPARK mode and add missing + basic contracts. Mark the unit as always terminating. + * libgnat/a-nuflra.ads: Idem. + +2025-06-05 Javier Miranda <miranda@adacore.com> + + * exp_ch7.adb (Process_Object_Declaration): Avoid generating + duplicate names for master nodes. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * opt.ads: Remove useless variable. + * sem_ch9.adb (Analyze_Abort_Statement, Analyze_Accept_Alternative, + Analyze_Accept_Statement, Analyze_Asynchronous_Select, + Analyze_Conditional_Entry_Call, Analyze_Delay_Alternative, + Analyze_Delay_Relative, Analyze_Delay_Until, Analyze_Entry_Body, + Analyze_Entry_Body_Formal_Part, Analyze_Entry_Call_Alternative, + Analyze_Entry_Declaration, Analyze_Entry_Index_Specification, + Analyze_Protected_Body, Analyze_Protected_Definition, + Analyze_Protected_Type_Declaration, Analyze_Requeue, + Analyze_Selective_Accept, Analyze_Single_Protected_Declaration, + Analyze_Single_Task_Declaration, Analyze_Task_Body, + Analyze_Task_Definition, Analyze_Task_Type_Declaration, + Analyze_Terminate_Alternative, Analyze_Timed_Entry_Call, + Analyze_Triggering_Alternative): Remove useless assignments. + +2025-06-05 Steve Baird <baird@adacore.com> + + * sem_util.adb + (Side_Effect_Free_Statements): Return False if the statement list + includes an explicit (i.e. Comes_From_Source) raise statement. + +2025-06-05 Javier Miranda <miranda@adacore.com> + + * sem_ch6.adb (Analyze_Expression_Function): Add missing check + on premature use of incomplete type. + +2025-06-05 Aleksandra Pasek <pasek@adacore.com> + + * libgnat/s-arit32.adb: Add Ghost aspect to Lo. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * exp_ch4.adb (Tagged_Membership): Fix for protected types. + +2025-06-05 Bob Duff <duff@adacore.com> + + * sem_eval.adb (Fold_Shift): If the Amount parameter is greater + than the size in bits, use the size. For example, if we are + shifting an Unsigned_8 value, then Amount => 1_000_001 gives the + same result as Amount => 8. This change avoids computing the value + of 2**1_000_000, which takes too long and uses too much memory. + Note that the computation we're talking about is a compile-time + computation. Minor cleanup. DRY. + * sem_eval.ads (Fold_Str, Fold_Uint, Fold_Ureal): Fold the + comments into one comment, because DRY. Remove useless + verbiage. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * exp_attr.adb (Interunit_Ref_OK): Tweak categorization of compilation + units. + +2025-06-05 Aleksandra Pasek <pasek@adacore.com> + + * libgnat/s-aridou.adb: Add missing Ghost aspect to + Lemma_Not_In_Range_Big2xx64. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * libgnat/s-trasym__dwarf.adb (Init_Module): Add mitigation. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Build_Two_Pass_Aggr_Code): New function containing + most of the code initially present in Two_Pass_Aggregate_Expansion. + (Two_Pass_Aggregate_Expansion): Remove redundant N parameter. + Implement built-in-place expansion for (static) object declarations + and allocators, using Build_Two_Pass_Aggr_Code for the main work. + (Expand_Array_Aggregate): Adjust Two_Pass_Aggregate_Expansion call. + Replace Etype (N) by Typ in a couple of places. + * exp_ch3.adb (Expand_Freeze_Array_Type): Remove special case for + two-pass array aggregates. + (Expand_N_Object_Declaration): Do not adjust the object when it is + initialized by a two-pass array aggregate. + * exp_ch4.adb (Expand_Allocator_Expression): Apply the processing + used for container aggregates to two-pass array aggregates. + * exp_ch6.adb (Validate_Subprogram_Calls): Skip calls present in + initialization expressions of N_Object_Declaration nodes that have + No_Initialization set. + * sem_ch3.adb (Analyze_Object_Declaration): Detect the cases of an + array originally initialized by an aggregate consistently. + +2025-06-05 Johannes Kliemann <kliemann@adacore.com> + + * libgnat/s-arit32.adb (Lemma_Not_In_Range_Big2xx32): Add missing + Ghost aspect. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * generate_minimal_reproducer.adb (Generate_Minimal_Reproducer): Fix + handling of preprocessing dependencies. + +2025-06-05 Viljar Indus <indus@adacore.com> + + * doc/gnat_rm/implementation_defined_attributes.rst: Update the + documentation for Valid_Value. + * sem_attr.adb (Analyze_Attribute): Reject types where + the root type originates from Standard. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2025-06-05 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Two_Pass_Aggregate_Expansion): Change call to Make_Assignment + for the indexed aggregate object to call Change_Make_OK_Assignment instead. + +2025-06-05 Steve Baird <baird@adacore.com> + + * sem_prag.adb + (Analyze_Constituent): In the specific case case of a defined-too-late + abstract state constituent, generate an additional error message. + +2025-06-05 Viljar Indus <indus@adacore.com> + + * diagnostics-sarif_emitter.adb (Print_Invocations): fix + commandLine and executionSuccessful nodes. + Fix typo in the name for startLine. + * osint.adb (Modified Get_Current_Dir) Fix generation of + the current directory. + (Relative_Path): Avoid relative paths starting with a + path separator. + * osint.ads: Update the documentation for Relative_Path. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * libgnat/i-cstrin.adb (New_String): Fix size of allocation. + +2025-06-05 squirek <squirek@adacore.com> + + * sem_ch8.adb (Analyze_Package_Name): Add code to expand use + clauses such that they have an implicit with associated with them + when extensions are enabled. + * sem_ch10.ads (Analyze_With_Clause): New. + * sem_ch10.adb (Analyze_With_Clause): Add comes from source check + for warning. + (Expand_With_Clause): Moved to the spec. + * sem_util.adb, sem_util.ads + (Is_In_Context_Clause): Moved from sem_prag. + * sem_prag.adb (Analyze_Pragma): Update calls to + Is_In_Context_Clause. + (Is_In_Context_Clause): Moved to sem_util. + +2025-06-05 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_ugn/platform_specific_information.rst + (Setting Stack Size from gnatlink): Improve documentation. + * gnat-style.texi: Regenerate. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2025-06-05 squirek <squirek@adacore.com> + + * accessibility.adb (Check_Return_Construct_Accessibility): + Disable check generation when we are only checking semantics. + * opt.ads: Add new flag for -gnatc mode + * switch-c.adb (Scan_Front_End_Switches): Set flag for -gnatc mode + +2025-06-05 Viljar Indus <indus@adacore.com> + + * sem_ch8.adb (Mark_Use_Type): Additionally mark the types + of the parameters and return values as used when analyzing an + operator. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch9.adb (Build_Dispatching_Requeue): Take 'Tag of the + concurrent object instead of doing an unchecked conversion. + * exp_pakd.adb (Expand_Packed_Address_Reference): Perform address + arithmetic using an operator of System.Storage_Elements. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Remove obsolete comment. + (Make_Build_In_Place_Call_In_Anonymous_Context): Always use a proper + object declaration initialized with the function call in the cases + where a temporary is needed, with Assignment_OK set on it. + * sem_util.adb (Entity_Of): Deal with rewritten function call first. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * libgnat/i-cstrin.adb (Position_Of_Nul): Change specification and + adjust body accordingly. + (New_Char_Array): Fix size of allocation. + (To_Chars_Ptr): Adapt to Position_Of_Nul change. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * generate_minimal_reproducer.adb (Generate_Minimal_Reproducer): Fix + oracle generation. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * generate_minimal_reproducer.adb (Generate_Minimal_Reproducer): + Fix when main library item is an instantiation. + +2025-06-05 Steve Baird <baird@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): When accessing the + maps declared in package Cached_Attribute_Ops, the key value + passed to Get or to Set should never be the entity node for a + subtype. Use the entity of the corresponding type declaration + instead. + +2025-06-05 Viljar Indus <indus@adacore.com> + + * sem_res.adb (Resolve_Declare_Expression): Mark used + local variables inside a declare expression as referenced. + +2025-06-05 Javier Miranda <miranda@adacore.com> + + * sem.ads: Update reference to renamed subprogram in documentation. + * sem_ch3.ads (Preanalyze_Assert_Expression): Renamed. + (Preanalyze_Spec_Expression): Renamed. + * sem_ch3.adb (Preanalyze_Assert_Expression): Renamed and code cleanup. + (Preanalyze_Spec_Expression): Renamed. + (Preanalyze_Default_Expression): Renamed. + * contracts.adb: Update calls to renamed subprograms. + * exp_pakd.adb: Ditto. + * exp_util.adb: Ditto. + * freeze.adb: Ditto. + * sem_ch12.adb: Ditto. + * sem_ch13.adb: Ditto. + * sem_ch6.adb: Ditto. + * sem_prag.adb: Ditto. + * sem_res.adb (Preanalyze_And_Resolve): Add to the version without + context type the special handling for GNATprove mode provided by + the version with context type; required to cleanup the body of + Preanalyze_Assert_Expression. + +2025-06-05 squirek <squirek@adacore.com> + + * accessibility.adb + (Check_Return_Construct_Accessibility): Disable check generation + when we are only checking semantics. + +2025-06-05 Viljar Indus <indus@adacore.com> + + * diagnostics-json_utils.adb: Add new method To_File_Uri to + convert any path to the URI standard. + * diagnostics-json_utils.ads: Likewise. + * diagnostics-sarif_emitter.adb: Converted Artifact_Change + types to use the Source_File_Index instead of the file name + to store the source file. + Removed the body from Destroy (Elem : in out Artifact_Change) + since it no longer contained elements with dynamic memory. + Updated the implementation of Equals (L, R : Artifact_Change) + to take into account the changes for Artifact_Change. + Print_Artifact_Location: Use the Source_File_Index as an + input argument. Now prints the uriBaseId attribute and a + relative path from the uriBaseId to the file in question as + the value of the uri attribute. + New method Print_Original_Uri_Base_Ids to print the + originalUriBaseIds node. + Print_Run no prints the originalUriBaseIds node. + Use constants instead of strings for all the SARIF attributes. + * osint.adb: Add new method Relative_Path to calculate the + relative path from a base directory. + Add new method Root to calculate the root of each directory. + Add new method Get_Current_Dir to get the current working + directory for the execution environment. + * osint.ads: Likewise. + * clean.adb: Use full names for calls to Get_Current_Dir. + * gnatls.adb: Likewise. + +2025-06-05 Steve Baird <baird@adacore.com> + + * sem_res.adb + (Set_Mixed_Mode_Operand): If we are about to call Resolve + passing in Any_Fixed as the expected type, then instead pass in + the fixed point type of the other operand (i.e., B_Typ). + +2025-06-05 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Check_Function_Writable_Actuals): Add handling for + N_Iterated_Component_Association and N_Iterated_Element_Association. + Fix a typo in an RM reference (6.4.1(20/3) => 6.4.1(6.20/3)). + (Collect_Expression_Ids): New procedure factoring code for collecting + identifiers from expressions of aggregate associations. + (Handle_Association_Choices): New procedure factoring code for handling + id collection for expressions of aggregate associations with multiple + choices. Removed redundant test of Box_Present from original code. + 2025-05-24 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/Make-lang.in (ACATSDIR): Use acats-2 directory. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index cb41e68..bd36c31 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -211,7 +211,6 @@ GNATRTL_NONTASKING_OBJS= \ a-nallfl$(objext) \ a-nalofl$(objext) \ a-nashfl$(objext) \ - a-nbnbig$(objext) \ a-nbnbin$(objext) \ a-nbnbre$(objext) \ a-ncelfu$(objext) \ @@ -745,8 +744,6 @@ GNATRTL_NONTASKING_OBJS= \ s-shasto$(objext) \ s-soflin$(objext) \ s-soliin$(objext) \ - s-spark$(objext) \ - s-spcuop$(objext) \ s-spsufi$(objext) \ s-stache$(objext) \ s-stalib$(objext) \ @@ -772,7 +769,6 @@ GNATRTL_NONTASKING_OBJS= \ s-vaenu8$(objext) \ s-vafi32$(objext) \ s-vafi64$(objext) \ - s-vaispe$(objext) \ s-valboo$(objext) \ s-valcha$(objext) \ s-valflt$(objext) \ @@ -782,7 +778,6 @@ GNATRTL_NONTASKING_OBJS= \ s-vallli$(objext) \ s-valllu$(objext) \ s-valrea$(objext) \ - s-valspe$(objext) \ s-valued$(objext) \ s-valuef$(objext) \ s-valuei$(objext) \ @@ -792,14 +787,9 @@ GNATRTL_NONTASKING_OBJS= \ s-valuns$(objext) \ s-valuti$(objext) \ s-valwch$(objext) \ - s-vauspe$(objext) \ s-veboop$(objext) \ s-vector$(objext) \ s-vercon$(objext) \ - s-vs_int$(objext) \ - s-vs_lli$(objext) \ - s-vs_llu$(objext) \ - s-vs_uns$(objext) \ s-wchcnv$(objext) \ s-wchcon$(objext) \ s-wchjis$(objext) \ @@ -1046,8 +1036,6 @@ GNATRTL_128BIT_OBJS = \ s-vafi128$(objext) \ s-valllli$(objext) \ s-vallllu$(objext) \ - s-vsllli$(objext) \ - s-vslllu$(objext) \ s-widllli$(objext) \ s-widlllu$(objext) @@ -1419,24 +1407,32 @@ ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out arm% aarch64 linux-android%,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ + a-exetim.adb<libgnarl/a-exetim__posix.adb \ + a-exetim.ads<libgnarl/a-exetim__default.ads \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ + a-synbar.adb<libgnarl/a-synbar__posix.adb \ + a-synbar.ads<libgnarl/a-synbar__posix.ads \ + s-dorepr.adb<libgnat/s-dorepr__fma.adb \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__android.adb \ - s-osinte.adb<libgnarl/s-osinte__android.adb \ s-osinte.ads<libgnarl/s-osinte__android.ads \ + s-osinte.adb<libgnarl/s-osinte__android.adb \ s-oslock.ads<libgnat/s-oslock__posix.ads \ s-osprim.adb<libgnat/s-osprim__posix.adb \ - s-taprop.adb<libgnarl/s-taprop__posix.adb \ + s-parame.adb<libgnat/s-parame__aarch64-linux.adb \ + s-taprop.adb<libgnarl/s-taprop__linux.adb \ + s-tasinf.ads<libgnarl/s-tasinf__linux.ads \ + s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ + s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ s-taspri.ads<libgnarl/s-taspri__posix.ads \ - s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ - a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ system.ads<libgnat/system-linux-arm.ads TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb - EXTRA_GNATRTL_TASKING_OBJS=s-linux.o + EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o # ARM and aarch64 rely on different unwinding mechanisms, and as # a 64bit target, aarch64 can also incorporate support for 128bit diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 8c85173..0b8d3f7 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -1642,6 +1642,13 @@ package body Accessibility is (No (Extra_Accessibility_Of_Result (Scope_Id)) and then Is_Formal_Of_Current_Function (Assoc_Expr) and then Is_Tagged_Type (Etype (Scope_Id))) + + -- Disable the check generation when we are only checking semantics + -- since required locals do not get generated (e.g. extra + -- accessibility of result), and constant folding can occur and + -- lead to spurious errors. + + and then not Check_Semantics_Only_Mode then -- Generate a dynamic check based on the extra accessibility of -- the result or the scope of the current function. @@ -1684,8 +1691,8 @@ package body Accessibility is and then Entity (Check_Cond) = Standard_True then Error_Msg_N - ("access discriminant in return object would be a dangling" - & " reference", Return_Stmt); + ("access discriminant in return object could be a dangling" + & " reference??", Return_Stmt); end if; end if; diff --git a/gcc/ada/ada_get_targ.adb b/gcc/ada/ada_get_targ.adb index 72e5452..853197a 100644 --- a/gcc/ada/ada_get_targ.adb +++ b/gcc/ada/ada_get_targ.adb @@ -219,9 +219,14 @@ package body Get_Targ is begin Float_Str (Float_Str'First .. Float_Str'First + 4) := "float"; Call_Back - (C_Name => Float_Str, Digs => 6, Complex => False, Count => 0, + (C_Name => Float_Str, + Digs => 6, + Complex => False, + Count => 0, Float_Rep => IEEE_Binary, - Precision => 32, Size => 32, Alignment => 32); + Precision => 32, + Size => 32, + Alignment => 32); Double_Str (Double_Str'First .. Double_Str'First + 5) := "double"; Call_Back diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 1fcfae1..63130e0 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -3475,7 +3475,7 @@ __gnat_lwp_self (void) } #endif -#if defined (__linux__) +#if defined (__linux__) || defined (__ANDROID__) #include <sched.h> /* glibc versions earlier than 2.7 do not define the routines to handle diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 70ea120..5e61450 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -81,6 +81,7 @@ package Aspects is Aspect_Bit_Order, Aspect_Component_Size, Aspect_Constant_Indexing, + Aspect_Constructor, -- GNAT Aspect_Contract_Cases, -- GNAT Aspect_Convention, Aspect_CPU, @@ -106,6 +107,7 @@ package Aspects is Aspect_GNAT_Annotate, -- GNAT Aspect_Implicit_Dereference, Aspect_Initial_Condition, -- GNAT + Aspect_Initialize, -- GNAT Aspect_Initializes, -- GNAT Aspect_Input, Aspect_Integer_Literal, @@ -130,6 +132,7 @@ package Aspects is Aspect_Predicate, -- GNAT Aspect_Predicate_Failure, Aspect_Priority, + Aspect_Program_Exit, Aspect_Put_Image, Aspect_Read, Aspect_Real_Literal, @@ -428,6 +431,7 @@ package Aspects is Aspect_Bit_Order => Expression, Aspect_Component_Size => Expression, Aspect_Constant_Indexing => Name, + Aspect_Constructor => Name, Aspect_Contract_Cases => Expression, Aspect_Convention => Name, Aspect_CPU => Expression, @@ -453,6 +457,7 @@ package Aspects is Aspect_GNAT_Annotate => Expression, Aspect_Implicit_Dereference => Name, Aspect_Initial_Condition => Expression, + Aspect_Initialize => Expression, Aspect_Initializes => Expression, Aspect_Input => Name, Aspect_Integer_Literal => Name, @@ -477,6 +482,7 @@ package Aspects is Aspect_Predicate => Expression, Aspect_Predicate_Failure => Expression, Aspect_Priority => Expression, + Aspect_Program_Exit => Optional_Expression, Aspect_Put_Image => Name, Aspect_Read => Name, Aspect_Real_Literal => Name, @@ -529,6 +535,7 @@ package Aspects is Aspect_Component_Size => True, Aspect_Constant_Indexing => False, Aspect_Contract_Cases => False, + Aspect_Constructor => False, Aspect_Convention => True, Aspect_CPU => False, Aspect_Default_Component_Value => True, @@ -556,6 +563,7 @@ package Aspects is Aspect_GNAT_Annotate => False, Aspect_Implicit_Dereference => False, Aspect_Initial_Condition => False, + Aspect_Initialize => False, Aspect_Initializes => False, Aspect_Input => False, Aspect_Integer_Literal => False, @@ -580,6 +588,7 @@ package Aspects is Aspect_Predicate => False, Aspect_Predicate_Failure => False, Aspect_Priority => False, + Aspect_Program_Exit => False, Aspect_Put_Image => False, Aspect_Read => False, Aspect_Real_Literal => False, @@ -698,6 +707,7 @@ package Aspects is Aspect_Constant_After_Elaboration => Name_Constant_After_Elaboration, Aspect_Constant_Indexing => Name_Constant_Indexing, Aspect_Contract_Cases => Name_Contract_Cases, + Aspect_Constructor => Name_Constructor, Aspect_Convention => Name_Convention, Aspect_CPU => Name_CPU, Aspect_CUDA_Device => Name_CUDA_Device, @@ -742,6 +752,7 @@ package Aspects is Aspect_Inline => Name_Inline, Aspect_Inline_Always => Name_Inline_Always, Aspect_Initial_Condition => Name_Initial_Condition, + Aspect_Initialize => Name_Initialize, Aspect_Initializes => Name_Initializes, Aspect_Input => Name_Input, Aspect_Integer_Literal => Name_Integer_Literal, @@ -780,6 +791,7 @@ package Aspects is Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization, Aspect_Preelaborate => Name_Preelaborate, Aspect_Priority => Name_Priority, + Aspect_Program_Exit => Name_Program_Exit, Aspect_Pure => Name_Pure, Aspect_Pure_Function => Name_Pure_Function, Aspect_Put_Image => Name_Put_Image, @@ -965,6 +977,7 @@ package Aspects is Aspect_Asynchronous => Always_Delay, Aspect_Attach_Handler => Always_Delay, Aspect_Constant_Indexing => Always_Delay, + Aspect_Constructor => Always_Delay, Aspect_CPU => Always_Delay, Aspect_CUDA_Device => Always_Delay, Aspect_CUDA_Global => Always_Delay, @@ -1009,6 +1022,7 @@ package Aspects is Aspect_Preelaborable_Initialization => Always_Delay, Aspect_Preelaborate => Always_Delay, Aspect_Priority => Always_Delay, + Aspect_Program_Exit => Always_Delay, Aspect_Pure => Always_Delay, Aspect_Pure_Function => Always_Delay, Aspect_Put_Image => Always_Delay, @@ -1070,6 +1084,7 @@ package Aspects is Aspect_Import => Never_Delay, Aspect_Initial_Condition => Never_Delay, Aspect_Local_Restrictions => Never_Delay, + Aspect_Initialize => Never_Delay, Aspect_Initializes => Never_Delay, Aspect_Max_Entry_Queue_Length => Never_Delay, Aspect_Max_Queue_Length => Never_Delay, diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index dc5fe0d..c8cc2bc 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -299,20 +299,19 @@ package Atree is -- This function allocates a new node, and then initializes it by copying -- the contents of the source node into it. The contents of the source node -- is not affected. The target node is always marked as not being in a list - -- (even if the source is a list member), and not overloaded. The new node - -- will have an extension if the source has an extension. New_Copy (Empty) - -- returns Empty, and New_Copy (Error) returns Error. Note that, unlike - -- Copy_Separate_Tree, New_Copy does not recursively copy any descendants, - -- so in general parent pointers are not set correctly for the descendants - -- of the copied node. + -- (even if the source is a list member), and not overloaded. + -- New_Copy (Empty) returns Empty, and New_Copy (Error) returns Error. Note + -- that, unlike Copy_Separate_Tree, New_Copy does not recursively copy any + -- descendants, so in general parent pointers are not set correctly for the + -- descendants of the copied node. function Relocate_Node (Source : Node_Id) return Node_Id; -- Source is a non-entity node that is to be relocated. A new node is -- allocated, and the contents of Source are copied to this node, using -- New_Copy. The parent pointers of descendants of the node are then -- adjusted to point to the relocated copy. The original node is not - -- modified, but the parent pointers of its descendants are no longer - -- valid. The new copy is always marked as not overloaded. This routine is + -- modified, but the parent pointers of its children no longer point back + -- at it. The new copy is always marked as not overloaded. This routine is -- used in conjunction with the tree rewrite routines (see descriptions of -- Replace/Rewrite). -- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index dcfcaa3..6a98292 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -8163,6 +8163,7 @@ package body Checks is end if; declare + Decl : Node_Id; CE : Node_Id; PV : Node_Id; Var_Id : Entity_Id; @@ -8215,12 +8216,20 @@ package body Checks is Mutate_Ekind (Var_Id, E_Variable); Set_Etype (Var_Id, Typ); - Insert_Action (Exp, + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Var_Id, Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => New_Copy_Tree (Exp)), - Suppress => Validity_Check); + Expression => New_Copy_Tree (Exp)); + + -- We might be validity-checking object whose type is declared as + -- limited but completion is a scalar type. We need to explicitly + -- flag its assignment as OK, as otherwise it would be rejected by + -- the language rules. + + Set_Assignment_OK (Decl); + + Insert_Action (Exp, Decl, Suppress => Validity_Check); Set_Validated_Object (Var_Id, New_Copy_Tree (Exp)); diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index f28cf69..dcbeffe 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -319,7 +319,9 @@ package body Clean is Delete ("", Executable); end if; - Delete_Binder_Generated_Files (Get_Current_Dir, Source); + Delete_Binder_Generated_Files + (GNAT.Directory_Operations.Get_Current_Dir, + Source); end; end if; end loop; @@ -405,7 +407,8 @@ package body Clean is Source : File_Name_Type) is Source_Name : constant String := Get_Name_String (Source); - Current : constant String := Get_Current_Dir; + Current : constant String := + GNAT.Directory_Operations.Get_Current_Dir; Last : constant Positive := B_Start'Length + Source_Name'Length; File_Name : String (1 .. Last + 4); diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 8b94a67..810458a 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -110,8 +110,8 @@ package body Contracts is -- Expand the contracts of a subprogram body and its correspoding spec (if -- any). This routine processes all [refined] pre- and postconditions as -- well as Always_Terminates, Contract_Cases, Exceptional_Cases, - -- Subprogram_Variant, invariants and predicates. Body_Id denotes the - -- entity of the subprogram body. + -- Program_Exit, Subprogram_Variant, invariants and predicates. Body_Id + -- denotes the entity of the subprogram body. procedure Preanalyze_Condition (Subp : Entity_Id; @@ -235,6 +235,7 @@ package body Contracts is -- Interrupt_Handler -- Postcondition -- Precondition + -- Program_Exit -- Side_Effects -- Subprogram_Variant -- Test_Case @@ -267,6 +268,7 @@ package body Contracts is | Name_Contract_Cases | Name_Exceptional_Cases | Name_Exit_Cases + | Name_Program_Exit | Name_Subprogram_Variant | Name_Test_Case then @@ -647,9 +649,9 @@ package body Contracts is end if; -- Deal with preconditions, [refined] postconditions, Always_Terminates, - -- Contract_Cases, Exceptional_Cases, Subprogram_Variant, invariants and - -- predicates associated with body and its spec. Do not expand the - -- contract of subprogram body stubs. + -- Contract_Cases, Exceptional_Cases, Program_Exit, Subprogram_Variant, + -- invariants and predicates associated with body and its spec. Do not + -- expand the contract of subprogram body stubs. if Nkind (Body_Decl) = N_Subprogram_Body then Expand_Subprogram_Contract (Body_Id); @@ -797,6 +799,9 @@ package body Contracts is elsif Prag_Nam = Name_Exceptional_Cases then Analyze_Exceptional_Cases_In_Decl_Part (Prag); + elsif Prag_Nam = Name_Program_Exit then + Analyze_Program_Exit_In_Decl_Part (Prag); + elsif Prag_Nam = Name_Subprogram_Variant then Analyze_Subprogram_Variant_In_Decl_Part (Prag); @@ -1413,6 +1418,7 @@ package body Contracts is -- Global -- Postcondition -- Precondition + -- Program_Exit -- Subprogram_Variant -- Test_Case @@ -2422,6 +2428,7 @@ package body Contracts is -- verify the return value. Result := Make_Defining_Identifier (Loc, Name_uResult); + Mutate_Ekind (Result, E_Constant); Set_Etype (Result, Typ); -- Add an invariant check when the return type has invariants and @@ -2761,6 +2768,9 @@ package body Contracts is elsif Pragma_Name (Prag) = Name_Exit_Cases then Expand_Pragma_Exit_Cases (Prag); + elsif Pragma_Name (Prag) = Name_Program_Exit then + Expand_Pragma_Program_Exit (Prag); + elsif Pragma_Name (Prag) = Name_Subprogram_Variant then Expand_Pragma_Subprogram_Variant (Prag => Prag, @@ -4909,7 +4919,7 @@ package body Contracts is Install_Formals (Subp); Inside_Class_Condition_Preanalysis := True; - Preanalyze_Spec_Expression (Expr, Standard_Boolean); + Preanalyze_And_Resolve_Spec_Expression (Expr, Standard_Boolean); Inside_Class_Condition_Preanalysis := False; End_Scope; diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads index ca9f84f..8b82037 100644 --- a/gcc/ada/contracts.ads +++ b/gcc/ada/contracts.ads @@ -56,6 +56,7 @@ package Contracts is -- Part_Of -- Postcondition -- Precondition + -- Program_Exit -- Refined_Depends -- Refined_Global -- Refined_Post @@ -90,6 +91,7 @@ package Contracts is -- Global (stand alone subprogram body) -- Postcondition (stand alone subprogram body) -- Precondition (stand alone subprogram body) + -- Program_Exit (stand alone subprogram body) -- Refined_Depends -- Refined_Global -- Refined_Post @@ -110,6 +112,7 @@ package Contracts is -- Global -- Postcondition -- Precondition + -- Program_Exit -- Subprogram_Variant -- Test_Case -- @@ -186,6 +189,7 @@ package Contracts is -- Global -- Postcondition -- Precondition + -- Program_Exit -- Refined_Depends -- Refined_Global -- Refined_Post diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 5ba88b9..1dc0698 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -67,10 +67,10 @@ package body CStand is procedure Build_Float_Type (E : Entity_Id; - Digs : Int; + Digs : Pos; Rep : Float_Rep_Kind; Siz : Int; - Align : Int); + Align : Nat); -- Procedure to build standard predefined float base type. The first -- parameter is the entity for the type. The second parameter is the -- digits value. The third parameter indicates the representation to @@ -192,10 +192,10 @@ package body CStand is procedure Build_Float_Type (E : Entity_Id; - Digs : Int; + Digs : Pos; Rep : Float_Rep_Kind; Siz : Int; - Align : Int) + Align : Nat) is begin Set_Type_Definition (Parent (E), @@ -612,27 +612,14 @@ package body CStand is Set_Is_Pure (Standard_Standard); Set_Is_Compilation_Unit (Standard_Standard); - -- Create type/subtype declaration nodes for standard types + -- Create type declaration nodes for standard types for S in S_Types loop - - -- Subtype declaration case - - if S = S_Natural or else S = S_Positive then - Decl := New_Node (N_Subtype_Declaration, Stloc); - Set_Subtype_Indication (Decl, - New_Occurrence_Of (Standard_Integer, Stloc)); - - -- Full type declaration case - - else + if S not in S_Natural | S_Positive then Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Entity (S)); + Append (Decl, Decl_S); end if; - - Set_Is_Frozen (Standard_Entity (S)); - Set_Is_Public (Standard_Entity (S)); - Set_Defining_Identifier (Decl, Standard_Entity (S)); - Append (Decl, Decl_S); end loop; Create_Back_End_Float_Types; @@ -1023,6 +1010,14 @@ package body CStand is Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); Set_Is_Constrained (Standard_Natural); + Append_To + (Decl_S, + Make_Subtype_Declaration + (Stloc, + Standard_Natural, + Subtype_Indication => + New_Occurrence_Of (Standard_Integer, Stloc))); + -- Setup entity for Positive Mutate_Ekind (Standard_Positive, E_Signed_Integer_Subtype); @@ -1040,6 +1035,14 @@ package body CStand is Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); Set_Is_Constrained (Standard_Positive); + Append_To + (Decl_S, + Make_Subtype_Declaration + (Stloc, + Standard_Positive, + Subtype_Indication => + New_Occurrence_Of (Standard_Integer, Stloc))); + -- Create declaration for package ASCII Decl := New_Node (N_Package_Declaration, Stloc); @@ -2083,7 +2086,7 @@ package body CStand is Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent); Set_Scope (Ent, Standard_Standard); Build_Float_Type - (Ent, Pos (Digs), Float_Rep, Int (Size), Int (Alignment / 8)); + (Ent, Pos (Digs), Float_Rep, Int (Size), Nat (Alignment / 8)); Append_New_Elmt (Ent, Back_End_Float_Types); end Register_Float_Type; @@ -2092,7 +2095,7 @@ package body CStand is -- Set_Float_Bounds -- ---------------------- - procedure Set_Float_Bounds (Id : Entity_Id) is + procedure Set_Float_Bounds (Id : Entity_Id) is L : Node_Id; H : Node_Id; -- Low and high bounds of literal value diff --git a/gcc/ada/cstand.ads b/gcc/ada/cstand.ads index 62644fe..bfd3052 100644 --- a/gcc/ada/cstand.ads +++ b/gcc/ada/cstand.ads @@ -42,7 +42,7 @@ package CStand is -- The semantics info is in the format given by Entity_Info. The global -- variables Last_Standard_Node_Id and Last_Standard_List_Id are also set. - procedure Set_Float_Bounds (Id : Entity_Id); + procedure Set_Float_Bounds (Id : Entity_Id); -- Procedure to set bounds for float type or subtype. Id is the entity -- whose bounds and type are to be set (a floating-point type). diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index ac3ce41..3a39ec8 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -168,7 +168,7 @@ package body Debug is -- d_A Stop generation of ALI file -- d_B Warn on build-in-place function calls -- d_C - -- d_D Use improved diagnostics + -- d_D -- d_E Print diagnostics and switch repository -- d_F Encode full invocation paths in ALI files -- d_G diff --git a/gcc/ada/diagnostics-brief_emitter.adb b/gcc/ada/diagnostics-brief_emitter.adb deleted file mode 100644 index 0315b53..0000000 --- a/gcc/ada/diagnostics-brief_emitter.adb +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . B R I E F _ E M I T T E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Diagnostics.Utils; use Diagnostics.Utils; -with Erroutc; use Erroutc; -with Opt; use Opt; -with Output; use Output; - -package body Diagnostics.Brief_Emitter is - - procedure Print_Sub_Diagnostic - (Sub_Diag : Sub_Diagnostic_Type; - Diag : Diagnostic_Type); - - -------------------------- - -- Print_Sub_Diagnostic -- - -------------------------- - - procedure Print_Sub_Diagnostic - (Sub_Diag : Sub_Diagnostic_Type; - Diag : Diagnostic_Type) - is - -- In GNAT sub messages were grouped by the main messages by also having - -- the same location. In the brief printer we use the primary location - -- of the main diagnostic for all of the subdiagnostics. - Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag); - - Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr; - - Text : String_Ptr; - - Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last - else Error_Msg_Line_Length); - - Switch_Str : constant String := Get_Doc_Switch (Diag); - begin - Text := new String'(To_String (Sptr) & ": " - & Kind_To_String (Sub_Diag, Diag) & ": " - & Sub_Diag.Message.all); - - if Switch_Str /= "" then - Text := new String'(Text.all & " " & Switch_Str); - end if; - - if Diag.Warn_Err then - Text := new String'(Text.all & " [warning-as-error]"); - end if; - - Output_Text_Within (Text, Line_Length); - Write_Eol; - end Print_Sub_Diagnostic; - - ---------------------- - -- Print_Diagnostic -- - ---------------------- - - procedure Print_Diagnostic (Diag : Diagnostic_Type) is - use Sub_Diagnostic_Lists; - - Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag); - - Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr; - - Text : String_Ptr; - - Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last - else Error_Msg_Line_Length); - - Switch_Str : constant String := Get_Doc_Switch (Diag); - begin - Write_Str (To_String (Sptr) & ": "); - - -- Ignore the message prefix on Style messages. They will use - -- the (style) prefix within the message. - -- - -- Also disable the "error:" prefix if Unique_Error_Tag is unset. - - if (Diag.Kind = Style and then not Diag.Warn_Err) - or else (Diag.Kind = Error and then not Unique_Error_Tag) - then - Text := new String'(""); - else - Text := new String'(Kind_To_String (Diag) & ": "); - end if; - - Text := new String'(Text.all & Diag.Message.all); - - if Switch_Str /= "" then - Text := new String'(Text.all & " " & Switch_Str); - end if; - - if Diag.Warn_Err then - Text := new String'(Text.all & " [warning-as-error]"); - end if; - - Output_Text_Within (Text, Line_Length); - Write_Eol; - - if Present (Diag.Sub_Diagnostics) then - declare - - Sub_Diag : Sub_Diagnostic_Type; - - It : Iterator := Iterate (Diag.Sub_Diagnostics); - begin - while Has_Next (It) loop - Next (It, Sub_Diag); - - Print_Sub_Diagnostic (Sub_Diag, Diag); - end loop; - end; - end if; - - end Print_Diagnostic; -end Diagnostics.Brief_Emitter; diff --git a/gcc/ada/diagnostics-brief_emitter.ads b/gcc/ada/diagnostics-brief_emitter.ads deleted file mode 100644 index 706293e..0000000 --- a/gcc/ada/diagnostics-brief_emitter.ads +++ /dev/null @@ -1,28 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . B R I E F _ E M I T T E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Diagnostics.Brief_Emitter is - procedure Print_Diagnostic (Diag : Diagnostic_Type); -end Diagnostics.Brief_Emitter; diff --git a/gcc/ada/diagnostics-constructors.adb b/gcc/ada/diagnostics-constructors.adb deleted file mode 100644 index 0bc8750..0000000 --- a/gcc/ada/diagnostics-constructors.adb +++ /dev/null @@ -1,514 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . C O N S T R U C T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Sinfo.Nodes; use Sinfo.Nodes; -with Diagnostics.Utils; use Diagnostics.Utils; - -package body Diagnostics.Constructors is - - ----------------------------------------------- - -- Make_Default_Iterator_Not_Primitive_Error -- - ----------------------------------------------- - - function Make_Default_Iterator_Not_Primitive_Error - (Expr : Node_Id; - Subp : Entity_Id) return Diagnostic_Type - is - begin - return - Make_Diagnostic - (Msg => "improper function for default iterator", - Location => Primary_Labeled_Span (Expr), - Id => GNAT0001, - Kind => Diagnostics.Error, - Sub_Diags => - (1 => - Continuation - (Msg => - "default iterator defined " & - Sloc_To_String (Subp, Sloc (Expr)) & - " must be a local primitive or class-wide function", - Locations => - (1 => Primary_Labeled_Span (Subp))))); - end Make_Default_Iterator_Not_Primitive_Error; - - ------------------------------------------------- - -- Record_Default_Iterator_Not_Primitive_Error -- - ------------------------------------------------- - - procedure Record_Default_Iterator_Not_Primitive_Error - (Expr : Node_Id; - Subp : Entity_Id) - is - begin - Record_Diagnostic - (Make_Default_Iterator_Not_Primitive_Error (Expr, Subp)); - end Record_Default_Iterator_Not_Primitive_Error; - - --------------------------------------------------- - -- Make_Invalid_Operand_Types_For_Operator_Error -- - --------------------------------------------------- - - function Make_Invalid_Operand_Types_For_Operator_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) return Diagnostic_Type - is - begin - return - Make_Diagnostic - (Msg => "invalid operand types for operator " & To_Name (Op), - Location => Primary_Labeled_Span (Op), - Id => GNAT0002, - Kind => Diagnostics.Error, - Spans => - (1 => - (Secondary_Labeled_Span - (N => L, - Label => To_Type_Name (L_Type))), - 2 => - Secondary_Labeled_Span - (N => R, - Label => To_Type_Name (R_Type)))); - end Make_Invalid_Operand_Types_For_Operator_Error; - - ----------------------------------------------------- - -- Record_Invalid_Operand_Types_For_Operator_Error -- - ----------------------------------------------------- - - procedure Record_Invalid_Operand_Types_For_Operator_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) - is - - begin - Record_Diagnostic - (Make_Invalid_Operand_Types_For_Operator_Error - (Op, L, L_Type, R, R_Type)); - end Record_Invalid_Operand_Types_For_Operator_Error; - - --------------------------------------------------------- - -- Make_Invalid_Operand_Types_For_Operator_L_Int_Error -- - --------------------------------------------------------- - - function Make_Invalid_Operand_Types_For_Operator_L_Int_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) return Diagnostic_Type - is - begin - return - Make_Diagnostic - (Msg => "invalid operand types for operator " & To_Name (Op), - Location => Primary_Labeled_Span (Op), - Id => GNAT0003, - Kind => Diagnostics.Error, - Spans => - (1 => - (Secondary_Labeled_Span - (N => L, - Label => - "left operand has type " & - To_Name (L_Type))), - 2 => - Secondary_Labeled_Span - (N => R, - Label => - "right operand has type " & - To_Name (R_Type))), - Sub_Diags => - (1 => Suggestion (Msg => "Convert left operand to ""Integer""") - ) - ); - end Make_Invalid_Operand_Types_For_Operator_L_Int_Error; - - ----------------------------------------------------------- - -- Record_Invalid_Operand_Types_For_Operator_L_Int_Error -- - ----------------------------------------------------------- - - procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) - is - - begin - Record_Diagnostic - (Make_Invalid_Operand_Types_For_Operator_L_Int_Error - (Op, L, L_Type, R, R_Type)); - end Record_Invalid_Operand_Types_For_Operator_L_Int_Error; - - --------------------------------------------------------- - -- Make_Invalid_Operand_Types_For_Operator_R_Int_Error -- - --------------------------------------------------------- - - function Make_Invalid_Operand_Types_For_Operator_R_Int_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) return Diagnostic_Type - is - begin - return - Make_Diagnostic - (Msg => "invalid operand types for operator " & To_Name (Op), - Location => Primary_Labeled_Span (Op), - Id => GNAT0004, - Kind => Diagnostics.Error, - Spans => - (1 => - Secondary_Labeled_Span - (N => L, - Label => - "left operand has type " & - To_Name (L_Type)), - 2 => - Secondary_Labeled_Span - (N => R, - Label => - "right operand has type " & - To_Name (R_Type))), - Sub_Diags => - (1 => Suggestion (Msg => "Convert right operand to ""Integer""") - ) - ); - end Make_Invalid_Operand_Types_For_Operator_R_Int_Error; - - ----------------------------------------------------------- - -- Record_Invalid_Operand_Types_For_Operator_R_Int_Error -- - ----------------------------------------------------------- - - procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) - is - - begin - Record_Diagnostic - (Make_Invalid_Operand_Types_For_Operator_R_Int_Error - (Op, L, L_Type, R, R_Type)); - end Record_Invalid_Operand_Types_For_Operator_R_Int_Error; - - --------------------------------------------------------- - -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error -- - --------------------------------------------------------- - - function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error - (Op : Node_Id; - L : Node_Id) return Diagnostic_Type - is - - begin - return - Make_Diagnostic - (Msg => "invalid operand types for operator " & To_Name (Op), - Location => Primary_Labeled_Span (Op), - Id => GNAT0005, - Kind => Diagnostics.Error, - Spans => - (1 => - Secondary_Labeled_Span - (N => L, - Label => - "left operand is access type ") - ) - ); - end Make_Invalid_Operand_Types_For_Operator_L_Acc_Error; - - ----------------------------------------------------------- - -- Record_Invalid_Operand_Types_For_Operator_L_Acc_Error -- - ----------------------------------------------------------- - - procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error - (Op : Node_Id; - L : Node_Id) - is - begin - Record_Diagnostic - (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error - (Op, L)); - end Record_Invalid_Operand_Types_For_Operator_L_Acc_Error; - - --------------------------------------------------------- - -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error -- - --------------------------------------------------------- - - function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error - (Op : Node_Id; - R : Node_Id) return Diagnostic_Type - is - - begin - return - Make_Diagnostic - (Msg => "invalid operand types for operator " & To_Name (Op), - Location => Primary_Labeled_Span (Op), - Id => GNAT0006, - Kind => Diagnostics.Error, - Spans => - (1 => - Secondary_Labeled_Span - (N => R, - Label => - "right operand is access type ") - ) - ); - end Make_Invalid_Operand_Types_For_Operator_R_Acc_Error; - - ----------------------------------------------------------- - -- Record_Invalid_Operand_Types_For_Operator_R_Acc_Error -- - ----------------------------------------------------------- - - procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error - (Op : Node_Id; - R : Node_Id) - is - begin - Record_Diagnostic - (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error - (Op, R)); - end Record_Invalid_Operand_Types_For_Operator_R_Acc_Error; - - ----------------------------------------------------------- - -- Make_Invalid_Operand_Types_For_Operator_General_Error -- - ----------------------------------------------------------- - - function Make_Invalid_Operand_Types_For_Operator_General_Error - (Op : Node_Id) return Diagnostic_Type - is - - begin - return - Make_Diagnostic - (Msg => "invalid operand types for operator " & To_Name (Op), - Location => Primary_Labeled_Span (Op), - Id => GNAT0007, - Kind => Diagnostics.Error - ); - end Make_Invalid_Operand_Types_For_Operator_General_Error; - - ------------------------------------------------------------- - -- Record_Invalid_Operand_Types_For_Operator_General_Error -- - ------------------------------------------------------------- - - procedure Record_Invalid_Operand_Types_For_Operator_General_Error - (Op : Node_Id) - is - begin - Record_Diagnostic - (Make_Invalid_Operand_Types_For_Operator_General_Error (Op)); - end Record_Invalid_Operand_Types_For_Operator_General_Error; - - -------------------------------------------------- - -- Make_Pragma_No_Effect_With_Lock_Free_Warning -- - -------------------------------------------------- - - function Make_Pragma_No_Effect_With_Lock_Free_Warning - (Pragma_Node : Node_Id; Pragma_Name : Name_Id; - Lock_Free_Node : Node_Id; Lock_Free_Range : Node_Id) - return Diagnostic_Type - is - begin - return - Make_Diagnostic - (Msg => - "pragma " & '"' & Get_Name_String (Pragma_Name) & '"' & - " for " & To_Name (Lock_Free_Node) & - " has no effect when Lock_Free given", - Location => Primary_Labeled_Span (Pragma_Node, "No effect"), - Id => GNAT0008, - Kind => Diagnostics.Warning, - Spans => - (1 => - Labeled_Span - (Span => To_Full_Span (Lock_Free_Range), - Label => "Lock_Free in effect here", - Is_Primary => False, - Is_Region => True))); - end Make_Pragma_No_Effect_With_Lock_Free_Warning; - - -------------------------------------------- - -- Record_Pragma_No_Effect_With_Lock_Free -- - -------------------------------------------- - - procedure Record_Pragma_No_Effect_With_Lock_Free_Warning - (Pragma_Node : Node_Id; - Pragma_Name : Name_Id; - Lock_Free_Node : Node_Id; - Lock_Free_Range : Node_Id) - is - begin - Record_Diagnostic - (Make_Pragma_No_Effect_With_Lock_Free_Warning - (Pragma_Node, Pragma_Name, Lock_Free_Node, Lock_Free_Range)); - end Record_Pragma_No_Effect_With_Lock_Free_Warning; - - ---------------------------------- - -- Make_End_Loop_Expected_Error -- - ---------------------------------- - - function Make_End_Loop_Expected_Error - (End_Loc : Source_Span; - Start_Loc : Source_Ptr) return Diagnostic_Type - is - begin - return - Make_Diagnostic - (Msg => - """end loop;"" expected for ""loop"" " & - Sloc_To_String (Start_Loc, End_Loc.Ptr), - Location => Primary_Labeled_Span (End_Loc), - Id => GNAT0009, - Kind => Diagnostics.Error, - Spans => (1 => Secondary_Labeled_Span (To_Span (Start_Loc))), - Fixes => - (1 => - Fix - (Description => "Replace with 'end loop;'", - Edits => - (1 => Edit (Text => "end loop;", Span => End_Loc)), - Applicability => Legal))); - end Make_End_Loop_Expected_Error; - - ------------------------------------ - -- Record_End_Loop_Expected_Error -- - ------------------------------------ - - procedure Record_End_Loop_Expected_Error - (End_Loc : Source_Span; Start_Loc : Source_Ptr) - is - begin - Record_Diagnostic (Make_End_Loop_Expected_Error (End_Loc, Start_Loc)); - end Record_End_Loop_Expected_Error; - - ---------------------------------------- - -- Make_Representation_Too_Late_Error -- - ---------------------------------------- - - function Make_Representation_Too_Late_Error - (Rep : Node_Id; - Freeze : Node_Id; - Def : Node_Id) - return Diagnostic_Type - is - begin - return - Make_Diagnostic - (Msg => - "record representation cannot be specified" & - " after the type is frozen", - Location => - Primary_Labeled_Span - (N => Rep, - Label => "record representation clause specified here"), - Id => GNAT0010, - Kind => Error, - Spans => - (1 => - Secondary_Labeled_Span - (N => Freeze, - Label => - "Type " & To_Name (Def) & " is frozen here"), - 2 => - Secondary_Labeled_Span - (N => Def, - Label => - "Type " & To_Name (Def) & " is declared here")), - Sub_Diags => - (1 => - Suggestion - (Msg => - "move the record representation clause" & - " before the freeze point " & - Sloc_To_String (Sloc (Freeze), Sloc (Rep))))); - end Make_Representation_Too_Late_Error; - - ------------------------------------------ - -- Record_Representation_Too_Late_Error -- - ------------------------------------------ - - procedure Record_Representation_Too_Late_Error - (Rep : Node_Id; - Freeze : Node_Id; - Def : Node_Id) - is - begin - Record_Diagnostic - (Make_Representation_Too_Late_Error (Rep, Freeze, Def)); - end Record_Representation_Too_Late_Error; - - ------------------------------------------ - -- Make_Mixed_Container_Aggregate_Error -- - ------------------------------------------ - - function Make_Mixed_Container_Aggregate_Error - (Aggr : Node_Id; - Pos_Elem : Node_Id; - Named_Elem : Node_Id) return Diagnostic_Type - is - - begin - return - Make_Diagnostic - (Msg => - "container aggregate cannot be both positional and named", - Location => Primary_Labeled_Span (Aggr), - Id => GNAT0011, - Kind => Diagnostics.Error, - Spans => - (1 => Secondary_Labeled_Span - (Pos_Elem, "positional element "), - 2 => Secondary_Labeled_Span - (Named_Elem, "named element"))); - end Make_Mixed_Container_Aggregate_Error; - - -------------------------------------------- - -- Record_Mixed_Container_Aggregate_Error -- - -------------------------------------------- - - procedure Record_Mixed_Container_Aggregate_Error - (Aggr : Node_Id; - Pos_Elem : Node_Id; - Named_Elem : Node_Id) - is - begin - Record_Diagnostic - (Make_Mixed_Container_Aggregate_Error (Aggr, Pos_Elem, Named_Elem)); - end Record_Mixed_Container_Aggregate_Error; - -end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-constructors.ads b/gcc/ada/diagnostics-constructors.ads deleted file mode 100644 index a568f0f..0000000 --- a/gcc/ada/diagnostics-constructors.ads +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . C O N S T R U C T O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- -with Namet; use Namet; - -package Diagnostics.Constructors is - - function Make_Default_Iterator_Not_Primitive_Error - (Expr : Node_Id; - Subp : Entity_Id) return Diagnostic_Type; - - procedure Record_Default_Iterator_Not_Primitive_Error - (Expr : Node_Id; - Subp : Entity_Id); - - function Make_Invalid_Operand_Types_For_Operator_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) return Diagnostic_Type; - - procedure Record_Invalid_Operand_Types_For_Operator_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id); - - function Make_Invalid_Operand_Types_For_Operator_L_Int_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) return Diagnostic_Type; - - procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id); - - function Make_Invalid_Operand_Types_For_Operator_R_Int_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id) return Diagnostic_Type; - - procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error - (Op : Node_Id; - L : Node_Id; - L_Type : Node_Id; - R : Node_Id; - R_Type : Node_Id); - - function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error - (Op : Node_Id; - L : Node_Id) return Diagnostic_Type; - - procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error - (Op : Node_Id; - L : Node_Id); - - function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error - (Op : Node_Id; - R : Node_Id) return Diagnostic_Type; - - procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error - (Op : Node_Id; - R : Node_Id); - - function Make_Invalid_Operand_Types_For_Operator_General_Error - (Op : Node_Id) return Diagnostic_Type; - - procedure Record_Invalid_Operand_Types_For_Operator_General_Error - (Op : Node_Id); - - function Make_Pragma_No_Effect_With_Lock_Free_Warning - (Pragma_Node : Node_Id; - Pragma_Name : Name_Id; - Lock_Free_Node : Node_Id; - Lock_Free_Range : Node_Id) - return Diagnostic_Type; - - procedure Record_Pragma_No_Effect_With_Lock_Free_Warning - (Pragma_Node : Node_Id; - Pragma_Name : Name_Id; - Lock_Free_Node : Node_Id; - Lock_Free_Range : Node_Id); - - function Make_End_Loop_Expected_Error - (End_Loc : Source_Span; - Start_Loc : Source_Ptr) return Diagnostic_Type; - - procedure Record_End_Loop_Expected_Error - (End_Loc : Source_Span; - Start_Loc : Source_Ptr); - - function Make_Representation_Too_Late_Error - (Rep : Node_Id; - Freeze : Node_Id; - Def : Node_Id) - return Diagnostic_Type; - - procedure Record_Representation_Too_Late_Error - (Rep : Node_Id; - Freeze : Node_Id; - Def : Node_Id); - - function Make_Mixed_Container_Aggregate_Error - (Aggr : Node_Id; - Pos_Elem : Node_Id; - Named_Elem : Node_Id) return Diagnostic_Type; - - procedure Record_Mixed_Container_Aggregate_Error - (Aggr : Node_Id; - Pos_Elem : Node_Id; - Named_Elem : Node_Id); - -end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-converter.adb b/gcc/ada/diagnostics-converter.adb deleted file mode 100644 index b3d9edf..0000000 --- a/gcc/ada/diagnostics-converter.adb +++ /dev/null @@ -1,254 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . C O N V E R T E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- -with Erroutc; use Erroutc; -with Debug; use Debug; -with Diagnostics.Repository; use Diagnostics.Repository; -with Diagnostics.SARIF_Emitter; use Diagnostics.SARIF_Emitter; -with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; -with Opt; use Opt; -with Osint; use Osint; -with Output; use Output; -use Diagnostics.Diagnostics_Lists; -with System.OS_Lib; use System.OS_Lib; - -package body Diagnostics.Converter is - - function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type; - - function Convert_Sub_Diagnostic - (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type; - - function Get_Warning_Kind (E_Msg : Error_Msg_Object) return Diagnostic_Kind - is (if E_Msg.Warn_Chr = "* " then Restriction_Warning - elsif E_Msg.Warn_Chr = "? " then Default_Warning - elsif E_Msg.Warn_Chr = " " then Tagless_Warning - else Warning); - -- NOTE: Some messages have both info and warning set to true. The old - -- printer added the warning switch label but treated the message as - -- an info message. - - function Get_Diagnostics_Kind (E_Msg : Error_Msg_Object) - return Diagnostic_Kind - is (if E_Msg.Kind = Erroutc.Warning then Get_Warning_Kind (E_Msg) - elsif E_Msg.Kind = Erroutc.Style then Style - elsif E_Msg.Kind = Erroutc.Info then Info - elsif E_Msg.Kind = Erroutc.Non_Serious_Error then Non_Serious_Error - else Error); - - ----------------------------------- - -- Convert_Errors_To_Diagnostics -- - ----------------------------------- - - procedure Convert_Errors_To_Diagnostics - is - E : Error_Msg_Id; - begin - E := First_Error_Msg; - while E /= No_Error_Msg loop - - if not Errors.Table (E).Deleted - and then not Errors.Table (E).Msg_Cont - then - - -- We do not need to update the count of converted error messages - -- since they are accounted for in their creation. - - Record_Diagnostic (Convert (E), Update_Count => False); - end if; - - E := Errors.Table (E).Next; - end loop; - - end Convert_Errors_To_Diagnostics; - - ---------------------------- - -- Convert_Sub_Diagnostic -- - ---------------------------- - - function Convert_Sub_Diagnostic - (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type - is - E_Msg : constant Error_Msg_Object := Errors.Table (E_Id); - D : Sub_Diagnostic_Type; - begin - D.Message := E_Msg.Text; - - -- All converted sub-diagnostics are continuations. When emitted they - -- shall be printed with the same kind token as the main diagnostic. - D.Kind := Continuation; - - Add_Location (D, - Primary_Labeled_Span - (if E_Msg.Insertion_Sloc /= No_Location - then To_Span (E_Msg.Insertion_Sloc) - else E_Msg.Sptr)); - - if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then - Add_Location (D, Secondary_Labeled_Span (E_Msg.Optr)); - end if; - - return D; - end Convert_Sub_Diagnostic; - - ------------- - -- Convert -- - ------------- - - function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type is - - E_Next_Id : Error_Msg_Id; - - E_Msg : constant Error_Msg_Object := Errors.Table (E_Id); - D : Diagnostic_Type; - begin - D.Message := E_Msg.Text; - - D.Kind := Get_Diagnostics_Kind (E_Msg); - - if E_Msg.Kind in Erroutc.Warning | Erroutc.Style | Erroutc.Info then - D.Switch := Get_Switch_Id (E_Msg); - end if; - - D.Warn_Err := E_Msg.Warn_Err; - - -- Convert the primary location - - Add_Location (D, Primary_Labeled_Span (E_Msg.Sptr)); - - -- Convert the secondary location if it is different from the primary - - if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then - Add_Location (D, Secondary_Labeled_Span (E_Msg.Optr)); - end if; - - E_Next_Id := Errors.Table (E_Id).Next; - while E_Next_Id /= No_Error_Msg - and then Errors.Table (E_Next_Id).Msg_Cont - loop - Add_Sub_Diagnostic (D, Convert_Sub_Diagnostic (E_Next_Id)); - E_Next_Id := Errors.Table (E_Next_Id).Next; - end loop; - - return D; - end Convert; - - ---------------------- - -- Emit_Diagnostics -- - ---------------------- - - procedure Emit_Diagnostics is - D : Diagnostic_Type; - - It : Iterator := Iterate (All_Diagnostics); - - Sarif_File_Name : constant String := - Get_First_Main_File_Name & ".gnat.sarif"; - - Switches_File_Name : constant String := "gnat_switches.json"; - - Diagnostics_File_Name : constant String := "gnat_diagnostics.json"; - - Dummy : Boolean; - begin - if Opt.SARIF_Output then - Set_Standard_Error; - - Print_SARIF_Report (All_Diagnostics); - - Set_Standard_Output; - elsif Opt.SARIF_File then - Delete_File (Sarif_File_Name, Dummy); - declare - Output_FD : constant File_Descriptor := - Create_New_File - (Sarif_File_Name, - Fmode => Text); - - begin - Set_Output (Output_FD); - - Print_SARIF_Report (All_Diagnostics); - - Set_Standard_Output; - - Close (Output_FD); - end; - else - Set_Standard_Error; - - while Has_Next (It) loop - Next (It, D); - - Print_Diagnostic (D); - end loop; - - Set_Standard_Output; - end if; - - if Debug_Flag_Underscore_EE then - - -- Print the switch repository to a file - - Delete_File (Switches_File_Name, Dummy); - declare - Output_FD : constant File_Descriptor := - Create_New_File - (Switches_File_Name, - Fmode => Text); - - begin - Set_Output (Output_FD); - - Print_Switch_Repository; - - Set_Standard_Output; - - Close (Output_FD); - end; - - -- Print the diagnostics repository to a file - - Delete_File (Diagnostics_File_Name, Dummy); - declare - Output_FD : constant File_Descriptor := - Create_New_File - (Diagnostics_File_Name, - Fmode => Text); - - begin - Set_Output (Output_FD); - - Print_Diagnostic_Repository; - - Set_Standard_Output; - - Close (Output_FD); - end; - end if; - - Destroy (All_Diagnostics); - end Emit_Diagnostics; - -end Diagnostics.Converter; diff --git a/gcc/ada/diagnostics-converter.ads b/gcc/ada/diagnostics-converter.ads deleted file mode 100644 index a3b1579..0000000 --- a/gcc/ada/diagnostics-converter.ads +++ /dev/null @@ -1,31 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . C O N V E R T E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Diagnostics.Converter is - - procedure Convert_Errors_To_Diagnostics; - - procedure Emit_Diagnostics; -end Diagnostics.Converter; diff --git a/gcc/ada/diagnostics-switch_repository.ads b/gcc/ada/diagnostics-switch_repository.ads deleted file mode 100644 index afc4d1f..0000000 --- a/gcc/ada/diagnostics-switch_repository.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- -with Erroutc; use Erroutc; - -package Diagnostics.Switch_Repository is - - function Get_Switch (Id : Switch_Id) return Switch_Type; - - function Get_Switch (Diag : Diagnostic_Type) return Switch_Type; - - function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id; - - function Get_Switch_Id (Name : String) return Switch_Id; - - procedure Print_Switch_Repository; - -end Diagnostics.Switch_Repository; diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb deleted file mode 100644 index abde955..0000000 --- a/gcc/ada/diagnostics-utils.adb +++ /dev/null @@ -1,357 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . U T I L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Diagnostics.Repository; use Diagnostics.Repository; -with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; -with Errout; use Errout; -with Erroutc; use Erroutc; -with Namet; use Namet; -with Opt; use Opt; -with Sinput; use Sinput; -with Sinfo.Nodes; use Sinfo.Nodes; -with Warnsw; use Warnsw; - -package body Diagnostics.Utils is - - ------------------ - -- Get_Human_Id -- - ------------------ - - function Get_Human_Id (D : Diagnostic_Type) return String_Ptr is - begin - if D.Switch = No_Switch_Id then - return Diagnostic_Entries (D.Id).Human_Id; - else - return Get_Switch (D).Human_Id; - end if; - end Get_Human_Id; - - ------------------ - -- To_File_Name -- - ------------------ - - function To_File_Name (Sptr : Source_Ptr) return String is - Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr); - Ref_Name : constant File_Name_Type := - (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile) - else Reference_Name (Sfile)); - - begin - return Get_Name_String (Ref_Name); - end To_File_Name; - - -------------------- - -- Line_To_String -- - -------------------- - - function Line_To_String (Sptr : Source_Ptr) return String is - Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr); - Img_Raw : constant String := Int'Image (Int (Line)); - - begin - return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); - end Line_To_String; - - ---------------------- - -- Column_To_String -- - ---------------------- - - function Column_To_String (Sptr : Source_Ptr) return String is - Col : constant Column_Number := Get_Column_Number (Sptr); - Img_Raw : constant String := Int'Image (Int (Col)); - - begin - return - (if Col < 10 then "0" else "") - & Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); - end Column_To_String; - - --------------- - -- To_String -- - --------------- - - function To_String (Sptr : Source_Ptr) return String is - begin - return - To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" - & Column_To_String (Sptr); - end To_String; - - -------------------- - -- Sloc_To_String -- - -------------------- - - function Sloc_To_String - (N : Node_Or_Entity_Id; Ref : Source_Ptr) return String - is - - begin - return Sloc_To_String (Sloc (N), Ref); - end Sloc_To_String; - - -------------------- - -- Sloc_To_String -- - -------------------- - - function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String - is - - begin - if Sptr = No_Location then - return "at unknown location"; - - elsif Sptr = System_Location then - return "in package System"; - - elsif Sptr = Standard_Location then - return "in package Standard"; - - elsif Sptr = Standard_ASCII_Location then - return "in package Standard.ASCII"; - - else - if Full_File_Name (Get_Source_File_Index (Sptr)) - /= Full_File_Name (Get_Source_File_Index (Ref)) - then - return "at " & To_String (Sptr); - else - return "at line " & Line_To_String (Sptr); - end if; - end if; - end Sloc_To_String; - - ------------------ - -- To_Full_Span -- - ------------------ - - function To_Full_Span (N : Node_Id) return Source_Span - is - Fst, Lst : Node_Id; - begin - First_And_Last_Nodes (N, Fst, Lst); - return To_Span (Ptr => Sloc (N), - First => First_Sloc (Fst), - Last => Last_Sloc (Lst)); - end To_Full_Span; - - --------------- - -- To_String -- - --------------- - - function To_String (Id : Diagnostic_Id) return String is - begin - if Id = No_Diagnostic_Id then - return "GNAT0000"; - else - return Id'Img; - end if; - end To_String; - - ------------- - -- To_Name -- - ------------- - - function To_Name (E : Entity_Id) return String is - begin - -- The name of the node operator "&" has many special cases. Reuse the - -- node to name conversion implementation from the errout package for - -- now. - - Error_Msg_Node_1 := E; - Set_Msg_Text ("&", Sloc (E)); - - return Msg_Buffer (1 .. Msglen); - end To_Name; - - ------------------ - -- To_Type_Name -- - ------------------ - - function To_Type_Name (E : Entity_Id) return String is - begin - Error_Msg_Node_1 := E; - Set_Msg_Text ("}", Sloc (E)); - - return Msg_Buffer (1 .. Msglen); - end To_Type_Name; - - -------------------- - -- Kind_To_String -- - -------------------- - - function Kind_To_String - (D : Sub_Diagnostic_Type; - Parent : Diagnostic_Type) return String - is - (case D.Kind is - when Continuation => Kind_To_String (Parent), - when Help => "help", - when Note => "note", - when Suggestion => "suggestion"); - - -------------------- - -- Kind_To_String -- - -------------------- - - function Kind_To_String (D : Diagnostic_Type) return String is - (if D.Warn_Err then "error" - else - (case D.Kind is - when Diagnostics.Error | Non_Serious_Error => "error", - when Warning | Restriction_Warning | Default_Warning | - Tagless_Warning => "warning", - when Style => "style", - when Info => "info")); - - ------------------------------ - -- Get_Primary_Labeled_Span -- - ------------------------------ - - function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) - return Labeled_Span_Type - is - use Labeled_Span_Lists; - - S : Labeled_Span_Type; - It : Iterator; - begin - if Present (Spans) then - It := Iterate (Spans); - while Has_Next (It) loop - Next (It, S); - if S.Is_Primary then - return S; - end if; - end loop; - end if; - - return No_Labeled_Span; - end Get_Primary_Labeled_Span; - - -------------------- - -- Get_Doc_Switch -- - -------------------- - - function Get_Doc_Switch (Diag : Diagnostic_Type) return String is - begin - if Warning_Doc_Switch - and then Diag.Kind in Default_Warning - | Info - | Restriction_Warning - | Style - | Warning - then - if Diag.Switch = No_Switch_Id then - if Diag.Kind = Restriction_Warning then - return "[restriction warning]"; - - -- Info messages can have a switch tag but they should not have - -- a default switch tag. - - elsif Diag.Kind /= Info then - - -- For Default_Warning - - return "[enabled by default]"; - end if; - else - declare - S : constant Switch_Type := Get_Switch (Diag); - begin - return "[-" & S.Short_Name.all & "]"; - end; - end if; - end if; - - return ""; - end Get_Doc_Switch; - - -------------------- - -- Appears_Before -- - -------------------- - - function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean is - - begin - return Appears_Before (Primary_Location (D1).Span.Ptr, - Primary_Location (D2).Span.Ptr); - end Appears_Before; - - -------------------- - -- Appears_Before -- - -------------------- - - function Appears_Before (P1, P2 : Source_Ptr) return Boolean is - - begin - if Get_Source_File_Index (P1) = Get_Source_File_Index (P2) then - if Get_Logical_Line_Number (P1) = Get_Logical_Line_Number (P2) then - return Get_Column_Number (P1) < Get_Column_Number (P2); - else - return Get_Logical_Line_Number (P1) < Get_Logical_Line_Number (P2); - end if; - else - return Get_Source_File_Index (P1) < Get_Source_File_Index (P2); - end if; - end Appears_Before; - - ------------------------------ - -- Insert_Based_On_Location -- - ------------------------------ - - procedure Insert_Based_On_Location - (List : Diagnostic_List; - Diagnostic : Diagnostic_Type) - is - use Diagnostics_Lists; - - It : Iterator := Iterate (List); - D : Diagnostic_Type; - begin - -- This is the common scenario where the error is reported at the - -- natural order the tree is processed. This saves a lot of time when - -- looking for the correct position in the list when there are a lot of - -- diagnostics. - - if Present (List) and then - not Is_Empty (List) and then - Appears_Before (Last (List), Diagnostic) - then - Append (List, Diagnostic); - else - while Has_Next (It) loop - Next (It, D); - - if Appears_Before (Diagnostic, D) then - Insert_Before (List, D, Diagnostic); - return; - end if; - end loop; - - Append (List, Diagnostic); - end if; - end Insert_Based_On_Location; - -end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics-utils.ads b/gcc/ada/diagnostics-utils.ads deleted file mode 100644 index 33cd67f..0000000 --- a/gcc/ada/diagnostics-utils.ads +++ /dev/null @@ -1,91 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . U T I L S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Diagnostics.Utils is - - function Get_Human_Id (D : Diagnostic_Type) return String_Ptr; - - function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String; - -- Convert the source pointer to a string and prefix it with the correct - -- preposition. - -- - -- * If the location is in one of the standard locations, - -- then it yields "in package <LOCATION>". The explicit standard - -- locations are: - -- * System - -- * Standard - -- * Standard.ASCII - -- * if the location is missing the the sloc yields "at unknown location" - -- * if the location is in the same file as the current file, - -- then it yields "at line <line>". - -- * Otherwise sloc yields "at <file>:<line>:<column>" - - function Sloc_To_String (N : Node_Or_Entity_Id; - Ref : Source_Ptr) - return String; - -- Converts the Sloc of the node or entity to a Sloc string. - - function To_String (Sptr : Source_Ptr) return String; - -- Convert the source pointer to a string of the form: "file:line:column" - - function To_File_Name (Sptr : Source_Ptr) return String; - -- Converts the file name of the Sptr to a string. - - function Line_To_String (Sptr : Source_Ptr) return String; - -- Converts the logical line number of the Sptr to a string. - - function Column_To_String (Sptr : Source_Ptr) return String; - -- Converts the column number of the Sptr to a string. Column values less - -- than 10 are prefixed with a 0. - - function To_Full_Span (N : Node_Id) return Source_Span; - - function To_String (Id : Diagnostic_Id) return String; - -- Convert the diagnostic ID to a 4 character string padded with 0-s. - - function To_Name (E : Entity_Id) return String; - - function To_Type_Name (E : Entity_Id) return String; - - function Kind_To_String (D : Diagnostic_Type) return String; - - function Kind_To_String - (D : Sub_Diagnostic_Type; - Parent : Diagnostic_Type) return String; - - function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) - return Labeled_Span_Type; - - function Get_Doc_Switch (Diag : Diagnostic_Type) return String; - - function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean; - - function Appears_Before (P1, P2 : Source_Ptr) return Boolean; - - procedure Insert_Based_On_Location - (List : Diagnostic_List; - Diagnostic : Diagnostic_Type); - -end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics.adb b/gcc/ada/diagnostics.adb deleted file mode 100644 index c98eda2..0000000 --- a/gcc/ada/diagnostics.adb +++ /dev/null @@ -1,539 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Atree; use Atree; -with Debug; use Debug; -with Diagnostics.Brief_Emitter; -with Diagnostics.Pretty_Emitter; -with Diagnostics.Repository; use Diagnostics.Repository; -with Diagnostics.Utils; use Diagnostics.Utils; -with Lib; use Lib; -with Opt; use Opt; -with Sinput; use Sinput; -with Warnsw; - -package body Diagnostics is - - ------------- - -- Destroy -- - ------------- - - procedure Destroy (Elem : in out Labeled_Span_Type) is - begin - Free (Elem.Label); - end Destroy; - - ------------- - -- Destroy -- - ------------- - - procedure Destroy (Elem : in out Sub_Diagnostic_Type) is - begin - Free (Elem.Message); - if Labeled_Span_Lists.Present (Elem.Locations) then - Labeled_Span_Lists.Destroy (Elem.Locations); - end if; - end Destroy; - - ------------- - -- Destroy -- - ------------- - - procedure Destroy (Elem : in out Edit_Type) is - begin - Free (Elem.Text); - end Destroy; - - ------------- - -- Destroy -- - ------------- - - procedure Destroy (Elem : in out Fix_Type) is - begin - Free (Elem.Description); - if Edit_Lists.Present (Elem.Edits) then - Edit_Lists.Destroy (Elem.Edits); - end if; - end Destroy; - - ------------- - -- Destroy -- - ------------- - - procedure Destroy (Elem : in out Diagnostic_Type) is - begin - Free (Elem.Message); - if Labeled_Span_Lists.Present (Elem.Locations) then - Labeled_Span_Lists.Destroy (Elem.Locations); - end if; - if Sub_Diagnostic_Lists.Present (Elem.Sub_Diagnostics) then - Sub_Diagnostic_Lists.Destroy (Elem.Sub_Diagnostics); - end if; - if Fix_Lists.Present (Elem.Fixes) then - Fix_Lists.Destroy (Elem.Fixes); - end if; - end Destroy; - - ------------------ - -- Add_Location -- - ------------------ - - procedure Add_Location - (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type) - is - use Labeled_Span_Lists; - begin - if not Present (Diagnostic.Locations) then - Diagnostic.Locations := Create; - end if; - - Append (Diagnostic.Locations, Location); - end Add_Location; - - ---------------------- - -- Primary_Location -- - ---------------------- - - function Primary_Location - (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type - is - begin - return Get_Primary_Labeled_Span (Diagnostic.Locations); - end Primary_Location; - - ------------------ - -- Add_Location -- - ------------------ - - procedure Add_Location - (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type) - is - use Labeled_Span_Lists; - begin - if not Present (Diagnostic.Locations) then - Diagnostic.Locations := Create; - end if; - - Append (Diagnostic.Locations, Location); - end Add_Location; - - ------------------------ - -- Add_Sub_Diagnostic -- - ------------------------ - - procedure Add_Sub_Diagnostic - (Diagnostic : in out Diagnostic_Type; - Sub_Diagnostic : Sub_Diagnostic_Type) - is - use Sub_Diagnostic_Lists; - begin - if not Present (Diagnostic.Sub_Diagnostics) then - Diagnostic.Sub_Diagnostics := Create; - end if; - - Append (Diagnostic.Sub_Diagnostics, Sub_Diagnostic); - end Add_Sub_Diagnostic; - - procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type) is - use Edit_Lists; - begin - if not Present (Fix.Edits) then - Fix.Edits := Create; - end if; - - Append (Fix.Edits, Edit); - end Add_Edit; - - ------------- - -- Add_Fix -- - ------------- - - procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type) is - use Fix_Lists; - begin - if not Present (Diagnostic.Fixes) then - Diagnostic.Fixes := Create; - end if; - - Append (Diagnostic.Fixes, Fix); - end Add_Fix; - - ----------------------- - -- Record_Diagnostic -- - ----------------------- - - procedure Record_Diagnostic (Diagnostic : Diagnostic_Type; - Update_Count : Boolean := True) - is - - procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type); - - ----------------------------- - -- Update_Diagnostic_Count -- - ----------------------------- - - procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type) is - - begin - case Diagnostic.Kind is - when Error => - Total_Errors_Detected := Total_Errors_Detected + 1; - Serious_Errors_Detected := Serious_Errors_Detected + 1; - - when Non_Serious_Error => - Total_Errors_Detected := Total_Errors_Detected + 1; - - when Warning - | Default_Warning - | Tagless_Warning - | Restriction_Warning - | Style - => - Warnings_Detected := Warnings_Detected + 1; - - if Diagnostic.Warn_Err then - Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; - end if; - - when Info => - Info_Messages := Info_Messages + 1; - end case; - end Update_Diagnostic_Count; - - procedure Handle_Serious_Error; - -- Internal procedure to do all error message handling for a serious - -- error message, other than bumping the error counts and arranging - -- for the message to be output. - - procedure Handle_Serious_Error is - begin - -- Turn off code generation if not done already - - if Operating_Mode = Generate_Code then - Operating_Mode := Check_Semantics; - Expander_Active := False; - end if; - - -- Set the fatal error flag in the unit table unless we are in - -- Try_Semantics mode (in which case we set ignored mode if not - -- currently set. This stops the semantics from being performed - -- if we find a serious error. This is skipped if we are currently - -- dealing with the configuration pragma file. - - if Current_Source_Unit /= No_Unit then - declare - U : constant Unit_Number_Type := - Get_Source_Unit - (Primary_Location (Diagnostic).Span.Ptr); - begin - if Try_Semantics then - if Fatal_Error (U) = None then - Set_Fatal_Error (U, Error_Ignored); - end if; - else - Set_Fatal_Error (U, Error_Detected); - end if; - end; - end if; - - -- Disable warnings on unused use clauses and the like. Otherwise, an - -- error might hide a reference to an entity in a used package, so - -- after fixing the error, the use clause no longer looks like it was - -- unused. - - Warnsw.Check_Unreferenced := False; - Warnsw.Check_Unreferenced_Formals := False; - end Handle_Serious_Error; - begin - Insert_Based_On_Location (All_Diagnostics, Diagnostic); - - if Update_Count then - Update_Diagnostic_Count (Diagnostic); - end if; - - if Diagnostic.Kind = Error then - Handle_Serious_Error; - end if; - end Record_Diagnostic; - - ---------------------- - -- Print_Diagnostic -- - ---------------------- - - procedure Print_Diagnostic (Diagnostic : Diagnostic_Type) is - - begin - if Debug_Flag_FF then - Diagnostics.Pretty_Emitter.Print_Diagnostic (Diagnostic); - else - Diagnostics.Brief_Emitter.Print_Diagnostic (Diagnostic); - end if; - end Print_Diagnostic; - - ---------------------- - -- Primary_Location -- - ---------------------- - - function Primary_Location - (Diagnostic : Diagnostic_Type) return Labeled_Span_Type - is - begin - return Get_Primary_Labeled_Span (Diagnostic.Locations); - end Primary_Location; - - --------------------- - -- Make_Diagnostic -- - --------------------- - - function Make_Diagnostic - (Msg : String; - Location : Labeled_Span_Type; - Id : Diagnostic_Id := No_Diagnostic_Id; - Kind : Diagnostic_Kind := Diagnostics.Error; - Switch : Switch_Id := No_Switch_Id; - Spans : Labeled_Span_Array := No_Locations; - Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; - Fixes : Fix_Array := No_Fixes) - return Diagnostic_Type - is - D : Diagnostic_Type; - begin - D.Message := new String'(Msg); - D.Id := Id; - D.Kind := Kind; - - if Id /= No_Diagnostic_Id then - pragma Assert (Switch = Diagnostic_Entries (Id).Switch, - "Provided switch must be the same as in the registry"); - end if; - D.Switch := Switch; - - pragma Assert (Location.Is_Primary, "Main location must be primary"); - Add_Location (D, Location); - - for I in Spans'Range loop - Add_Location (D, Spans (I)); - end loop; - - for I in Sub_Diags'Range loop - Add_Sub_Diagnostic (D, Sub_Diags (I)); - end loop; - - for I in Fixes'Range loop - Add_Fix (D, Fixes (I)); - end loop; - - return D; - end Make_Diagnostic; - - ----------------------- - -- Record_Diagnostic -- - ----------------------- - - procedure Record_Diagnostic - (Msg : String; - Location : Labeled_Span_Type; - Id : Diagnostic_Id := No_Diagnostic_Id; - Kind : Diagnostic_Kind := Diagnostics.Error; - Switch : Switch_Id := No_Switch_Id; - Spans : Labeled_Span_Array := No_Locations; - Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; - Fixes : Fix_Array := No_Fixes) - is - - begin - Record_Diagnostic - (Make_Diagnostic - (Msg => Msg, - Location => Location, - Id => Id, - Kind => Kind, - Switch => Switch, - Spans => Spans, - Sub_Diags => Sub_Diags, - Fixes => Fixes)); - end Record_Diagnostic; - - ------------------ - -- Labeled_Span -- - ------------------ - - function Labeled_Span (Span : Source_Span; - Label : String := ""; - Is_Primary : Boolean := True; - Is_Region : Boolean := False) - return Labeled_Span_Type - is - L : Labeled_Span_Type; - begin - L.Span := Span; - if Label /= "" then - L.Label := new String'(Label); - end if; - L.Is_Primary := Is_Primary; - L.Is_Region := Is_Region; - - return L; - end Labeled_Span; - - -------------------------- - -- Primary_Labeled_Span -- - -------------------------- - - function Primary_Labeled_Span (Span : Source_Span; - Label : String := "") - return Labeled_Span_Type - is begin - return Labeled_Span (Span => Span, Label => Label, Is_Primary => True); - end Primary_Labeled_Span; - - -------------------------- - -- Primary_Labeled_Span -- - -------------------------- - - function Primary_Labeled_Span (N : Node_Or_Entity_Id; - Label : String := "") - return Labeled_Span_Type - is - begin - return Primary_Labeled_Span (To_Full_Span (N), Label); - end Primary_Labeled_Span; - - ---------------------------- - -- Secondary_Labeled_Span -- - ---------------------------- - - function Secondary_Labeled_Span - (Span : Source_Span; - Label : String := "") - return Labeled_Span_Type - is - begin - return Labeled_Span (Span => Span, Label => Label, Is_Primary => False); - end Secondary_Labeled_Span; - - ---------------------------- - -- Secondary_Labeled_Span -- - ---------------------------- - - function Secondary_Labeled_Span (N : Node_Or_Entity_Id; - Label : String := "") - return Labeled_Span_Type - is - begin - return Secondary_Labeled_Span (To_Full_Span (N), Label); - end Secondary_Labeled_Span; - - -------------- - -- Sub_Diag -- - -------------- - - function Sub_Diag (Msg : String; - Kind : Sub_Diagnostic_Kind := - Diagnostics.Continuation; - Locations : Labeled_Span_Array := No_Locations) - return Sub_Diagnostic_Type - is - S : Sub_Diagnostic_Type; - begin - S.Message := new String'(Msg); - S.Kind := Kind; - - for I in Locations'Range loop - Add_Location (S, Locations (I)); - end loop; - - return S; - end Sub_Diag; - - ------------------ - -- Continuation -- - ------------------ - - function Continuation (Msg : String; - Locations : Labeled_Span_Array := No_Locations) - return Sub_Diagnostic_Type - is - begin - return Sub_Diag (Msg, Diagnostics.Continuation, Locations); - end Continuation; - - ---------- - -- Help -- - ---------- - - function Help (Msg : String; - Locations : Labeled_Span_Array := No_Locations) - return Sub_Diagnostic_Type - is - begin - return Sub_Diag (Msg, Diagnostics.Help, Locations); - end Help; - - ---------------- - -- Suggestion -- - ---------------- - - function Suggestion (Msg : String; - Locations : Labeled_Span_Array := No_Locations) - return Sub_Diagnostic_Type - is - begin - return Sub_Diag (Msg, Diagnostics.Suggestion, Locations); - end Suggestion; - - --------- - -- Fix -- - --------- - - function Fix - (Description : String; - Edits : Edit_Array; - Applicability : Applicability_Type := Unspecified) return Fix_Type - is - F : Fix_Type; - begin - F.Description := new String'(Description); - - for I in Edits'Range loop - Add_Edit (F, Edits (I)); - end loop; - - F.Applicability := Applicability; - - return F; - end Fix; - - ---------- - -- Edit -- - ---------- - - function Edit (Text : String; Span : Source_Span) return Edit_Type is - - begin - return (Text => new String'(Text), Span => Span); - end Edit; - -end Diagnostics; diff --git a/gcc/ada/diagnostics.ads b/gcc/ada/diagnostics.ads deleted file mode 100644 index 67a8c20..0000000 --- a/gcc/ada/diagnostics.ads +++ /dev/null @@ -1,477 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2025, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Types; use Types; -with GNAT.Lists; use GNAT.Lists; - -package Diagnostics is - - type Diagnostic_Id is - (No_Diagnostic_Id, - GNAT0001, - GNAT0002, - GNAT0003, - GNAT0004, - GNAT0005, - GNAT0006, - GNAT0007, - GNAT0008, - GNAT0009, - GNAT0010, - GNAT0011); - - -- Labeled_Span_Type represents a span of source code that is associated - -- with a textual label. Primary spans indicate the primary location of the - -- diagnostic. Non-primary spans are used to indicate secondary locations. - -- - -- Spans can contain labels that are used to annotate the highlighted span. - -- Usually, the label is a short and concise message that provide - -- additional allthough non-critical information about the span. This is - -- an important since labels are not printed in the brief output and are - -- only present in the pretty and structural outputs. That is an important - -- distintion when choosing between a label and a sub-diagnostic. - type Labeled_Span_Type is record - Label : String_Ptr := null; - -- Text associated with the span - - Span : Source_Span := (others => No_Location); - -- Textual region in the source code - - Is_Primary : Boolean := True; - -- Primary spans are used to indicate the primary location of the - -- diagnostic. Typically there should just be one primary span per - -- diagnostic. - -- Non-primary spans are used to indicate secondary locations and - -- typically are formatted in a different way or omitted in some - -- contexts. - - Is_Region : Boolean := False; - -- Regional spans are multiline spans that have a unique way of being - -- displayed in the pretty output. - end record; - - No_Labeled_Span : constant Labeled_Span_Type := (others => <>); - - procedure Destroy (Elem : in out Labeled_Span_Type); - pragma Inline (Destroy); - - package Labeled_Span_Lists is new Doubly_Linked_Lists - (Element_Type => Labeled_Span_Type, - "=" => "=", - Destroy_Element => Destroy, - Check_Tampering => False); - subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List; - - type Sub_Diagnostic_Kind is - (Continuation, - Help, - Note, - Suggestion); - - -- Sub_Diagnostic_Type represents a sub-diagnostic message that is meant - -- to provide additional information about the primary diagnostic message. - -- - -- Sub-diagnostics are usually constructed with a full sentence as the - -- message and provide important context to the main diagnostic message or - -- some concrete action to the user. - -- - -- This is different from the labels of labeled spans which are meant to be - -- short and concise and are mostly there to annotate the higlighted span. - - type Sub_Diagnostic_Type is record - Kind : Sub_Diagnostic_Kind; - - Message : String_Ptr; - - Locations : Labeled_Span_List; - end record; - - procedure Add_Location - (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type); - - function Primary_Location - (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type; - - procedure Destroy (Elem : in out Sub_Diagnostic_Type); - pragma Inline (Destroy); - - package Sub_Diagnostic_Lists is new Doubly_Linked_Lists - (Element_Type => Sub_Diagnostic_Type, - "=" => "=", - Destroy_Element => Destroy, - Check_Tampering => False); - - subtype Sub_Diagnostic_List is Sub_Diagnostic_Lists.Doubly_Linked_List; - - -- An Edit_Type represents a textual edit that is associated with a Fix. - type Edit_Type is record - Span : Source_Span; - -- Region of the file to be removed - - Text : String_Ptr; - -- Text to be inserted at the start location of the span - end record; - - procedure Destroy (Elem : in out Edit_Type); - pragma Inline (Destroy); - - package Edit_Lists is new Doubly_Linked_Lists - (Element_Type => Edit_Type, - "=" => "=", - Destroy_Element => Destroy, - Check_Tampering => False); - - subtype Edit_List is Edit_Lists.Doubly_Linked_List; - - -- Type Applicability_Type will indicate the state of the resulting code - -- after applying a fix. - -- * Option Has_Placeholders indicates that the fix contains placeholders - -- that the user would need to fill. - -- * Option Legal indicates that applying the fix will result in legal Ada - -- code. - -- * Option Possibly_Illegal indicates that applying the fix will result in - -- possibly legal, but also possibly illegal Ada code. - type Applicability_Type is - (Has_Placeholders, - Legal, - Possibly_Illegal, - Unspecified); - - type Fix_Type is record - Description : String_Ptr := null; - -- Message describing the fix that will be displayed to the user. - - Applicability : Applicability_Type := Unspecified; - - Edits : Edit_List; - -- File changes for the fix. - end record; - - procedure Destroy (Elem : in out Fix_Type); - pragma Inline (Destroy); - - package Fix_Lists is new Doubly_Linked_Lists - (Element_Type => Fix_Type, - "=" => "=", - Destroy_Element => Destroy, - Check_Tampering => False); - - subtype Fix_List is Fix_Lists.Doubly_Linked_List; - - procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type); - - type Status_Type is - (Active, - Deprecated); - - type Switch_Id is ( - No_Switch_Id, - gnatwb, - gnatwc, - gnatwd, - gnatwf, - gnatwg, - gnatwh, - gnatwi, - gnatwj, - gnatwk, - gnatwl, - gnatwm, - gnatwo, - gnatwp, - gnatwq, - gnatwr, - gnatwt, - gnatwu, - gnatwv, - gnatww, - gnatwx, - gnatwy, - gnatwz, - gnatw_dot_a, - gnatw_dot_b, - gnatw_dot_c, - gnatw_dot_f, - gnatw_dot_h, - gnatw_dot_i, - gnatw_dot_j, - gnatw_dot_k, - gnatw_dot_l, - gnatw_dot_m, - gnatw_dot_n, - gnatw_dot_o, - gnatw_dot_p, - gnatw_dot_q, - gnatw_dot_r, - gnatw_dot_s, - gnatw_dot_t, - gnatw_dot_u, - gnatw_dot_v, - gnatw_dot_w, - gnatw_dot_x, - gnatw_dot_y, - gnatw_dot_z, - gnatw_underscore_a, - gnatw_underscore_c, - gnatw_underscore_j, - gnatw_underscore_l, - gnatw_underscore_p, - gnatw_underscore_q, - gnatw_underscore_r, - gnatw_underscore_s, - gnaty, - gnatya, - gnatyb, - gnatyc, - gnatyd, - gnatye, - gnatyf, - gnatyh, - gnatyi, - gnatyk, - gnatyl, - gnatym, - gnatyn, - gnatyo, - gnatyp, - gnatyr, - gnatys, - gnatyu, - gnatyx, - gnatyz, - gnatyaa, - gnatybb, - gnatycc, - gnatydd, - gnatyii, - gnatyll, - gnatymm, - gnatyoo, - gnatyss, - gnatytt, - gnatel - ); - - subtype Active_Switch_Id is Switch_Id range gnatwb .. gnatel; - -- The range of switch ids that represent switches that trigger a specific - -- diagnostic check. - - type Switch_Type is record - - Status : Status_Type := Active; - -- The status will indicate whether the switch is currently active, - -- or has been deprecated. A deprecated switch will not control - -- diagnostics, and will not be emitted by the GNAT usage. - - Human_Id : String_Ptr := null; - -- The Human_Id will be a unique and stable string-based ID which - -- identifies the content of the switch within the switch registry. - -- This ID will appear in SARIF readers. - - Short_Name : String_Ptr := null; - -- The Short_Name will denote the -gnatXX name of the switch. - - Description : String_Ptr := null; - -- The description will contain the description of the switch, as it is - -- currently emitted by the GNAT usage. - - Documentation_Url : String_Ptr := null; - -- The documentation_url will point to the AdaCore documentation site - -- for the switch. - - end record; - - type Diagnostic_Kind is - (Error, - Non_Serious_Error, - -- Typically all errors are considered serious and the compiler should - -- stop its processing since the tree is essentially invalid. However, - -- some errors are not serious and the compiler can continue its - -- processing to discover more critical errors. - Warning, - Default_Warning, - -- Warning representing the old warnings created with the '??' insertion - -- character. These warning have the [enabled by default] tag. - Restriction_Warning, - -- Warning representing the old warnings created with the '?*?' - -- insertion character. These warning have the [restriction warning] - -- tag. - Style, - Tagless_Warning, - -- Warning representing the old warnings created with the '?' insertion - -- character. - Info - ); - - type Diagnostic_Entry_Type is record - Status : Status_Type := Active; - - Human_Id : String_Ptr := null; - -- A human readable code for the diagnostic. If the diagnostic has a - -- switch with a human id then the human_id of the switch shall be used - -- in SARIF reports. - - Documentation : String_Ptr := null; - - Switch : Switch_Id := No_Switch_Id; - -- The switch that controls the diagnostic message. - end record; - - type Diagnostic_Type is record - - Id : Diagnostic_Id := No_Diagnostic_Id; - - Kind : Diagnostic_Kind := Error; - - Switch : Switch_Id := No_Switch_Id; - - Message : String_Ptr := null; - - Warn_Err : Boolean := False; - -- Signal whether the diagnostic was converted from a warning to an - -- error. This needs to be set during the message emission as this - -- behavior depends on the context of the code. - - Locations : Labeled_Span_List := Labeled_Span_Lists.Nil; - - Sub_Diagnostics : Sub_Diagnostic_List := Sub_Diagnostic_Lists.Nil; - - Fixes : Fix_List := Fix_Lists.Nil; - end record; - - procedure Destroy (Elem : in out Diagnostic_Type); - pragma Inline (Destroy); - - package Diagnostics_Lists is new Doubly_Linked_Lists - (Element_Type => Diagnostic_Type, - "=" => "=", - Destroy_Element => Destroy, - Check_Tampering => False); - - subtype Diagnostic_List is Diagnostics_Lists.Doubly_Linked_List; - - All_Diagnostics : Diagnostic_List := Diagnostics_Lists.Create; - - procedure Add_Location - (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type); - - procedure Add_Sub_Diagnostic - (Diagnostic : in out Diagnostic_Type; - Sub_Diagnostic : Sub_Diagnostic_Type); - - procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type); - - procedure Record_Diagnostic (Diagnostic : Diagnostic_Type; - Update_Count : Boolean := True); - - procedure Print_Diagnostic (Diagnostic : Diagnostic_Type); - - function Primary_Location - (Diagnostic : Diagnostic_Type) return Labeled_Span_Type; - - type Labeled_Span_Array is - array (Positive range <>) of Labeled_Span_Type; - type Sub_Diagnostic_Array is - array (Positive range <>) of Sub_Diagnostic_Type; - type Fix_Array is - array (Positive range <>) of Fix_Type; - type Edit_Array is - array (Positive range <>) of Edit_Type; - - No_Locations : constant Labeled_Span_Array (1 .. 0) := (others => <>); - No_Sub_Diags : constant Sub_Diagnostic_Array (1 .. 0) := (others => <>); - No_Fixes : constant Fix_Array (1 .. 0) := (others => <>); - No_Edits : constant Edit_Array (1 .. 0) := (others => <>); - - function Make_Diagnostic - (Msg : String; - Location : Labeled_Span_Type; - Id : Diagnostic_Id := No_Diagnostic_Id; - Kind : Diagnostic_Kind := Diagnostics.Error; - Switch : Switch_Id := No_Switch_Id; - Spans : Labeled_Span_Array := No_Locations; - Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; - Fixes : Fix_Array := No_Fixes) - return Diagnostic_Type; - - procedure Record_Diagnostic - (Msg : String; - Location : Labeled_Span_Type; - Id : Diagnostic_Id := No_Diagnostic_Id; - Kind : Diagnostic_Kind := Diagnostics.Error; - Switch : Switch_Id := No_Switch_Id; - Spans : Labeled_Span_Array := No_Locations; - Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; - Fixes : Fix_Array := No_Fixes); - - function Labeled_Span (Span : Source_Span; - Label : String := ""; - Is_Primary : Boolean := True; - Is_Region : Boolean := False) - return Labeled_Span_Type; - - function Primary_Labeled_Span (Span : Source_Span; - Label : String := "") - return Labeled_Span_Type; - - function Primary_Labeled_Span (N : Node_Or_Entity_Id; - Label : String := "") - return Labeled_Span_Type; - - function Secondary_Labeled_Span (Span : Source_Span; - Label : String := "") - return Labeled_Span_Type; - - function Secondary_Labeled_Span (N : Node_Or_Entity_Id; - Label : String := "") - return Labeled_Span_Type; - - function Sub_Diag (Msg : String; - Kind : Sub_Diagnostic_Kind := - Diagnostics.Continuation; - Locations : Labeled_Span_Array := No_Locations) - return Sub_Diagnostic_Type; - - function Continuation (Msg : String; - Locations : Labeled_Span_Array := No_Locations) - return Sub_Diagnostic_Type; - - function Help (Msg : String; - Locations : Labeled_Span_Array := No_Locations) - return Sub_Diagnostic_Type; - - function Suggestion (Msg : String; - Locations : Labeled_Span_Array := No_Locations) - return Sub_Diagnostic_Type; - - function Fix (Description : String; - Edits : Edit_Array; - Applicability : Applicability_Type := Unspecified) - return Fix_Type; - - function Edit (Text : String; - Span : Source_Span) - return Edit_Type; -end Diagnostics; diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst index ee2df66..1713f56 100644 --- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -657,6 +657,22 @@ An exception message can also be added: when Imported_C_Func /= 0; end; +Implicit With +------------- + +This feature allows a standalone ``use`` clause in the context clause of a +compilation unit to imply an implicit ``with`` of the same library unit where +an equivalent ``with`` clause would be allowed. + +.. code-block:: ada + + use Ada.Text_IO; + procedure Main is + begin + Put_Line ("Hello"); + end; + + Storage Model ------------- diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst index 61ea10c..a80da47 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst @@ -549,6 +549,12 @@ predicate is static or dynamic is controlled by the form of the expression. It is also separately controllable using pragma ``Assertion_Policy``. +Aspect Program_Exit +=================== +.. index:: Program_Exit + +This boolean aspect is equivalent to :ref:`pragma Program_Exit<Pragma-Program_Exit>`. + Aspect Pure_Function ==================== .. index:: Pure_Function diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index f051810..86d2a81 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -1629,9 +1629,9 @@ Attribute Valid_Value .. index:: Valid_Value The ``'Valid_Value`` attribute is defined for enumeration types other than -those in package Standard. This attribute is a function that takes -a String, and returns Boolean. ``T'Valid_Value (S)`` returns True -if and only if ``T'Value (S)`` would not raise Constraint_Error. +those in package Standard or types derived from those types. This attribute is +a function that takes a String, and returns Boolean. ``T'Valid_Value (S)`` +returns True if and only if ``T'Value (S)`` would not raise Constraint_Error. Attribute Valid_Scalars ======================= diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index d18ce36..cae8c16 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -1940,7 +1940,8 @@ Syntax: EXIT_CASE ::= GUARD => EXIT_KIND EXIT_KIND ::= Normal_Return | Exception_Raised - | (Exception_Raised => exception_name) + | (Exception_Raised => exception_name) + | Program_Exit GUARD ::= Boolean_expression For the semantics of this aspect, see the SPARK 2014 Reference Manual, section @@ -5285,6 +5286,20 @@ generating ``Restrictions`` pragmas, it generates violations of the profile generate warning messages instead of error messages. +.. _Pragma-Program_Exit: + +Pragma Program_Exit +=================== + +Syntax: + +.. code-block:: ada + + pragma Program_Exit [ (boolean_EXPRESSION) ]; + +For the semantics of this pragma, see the entry for aspect ``Program_Exit`` +in the SPARK 2014 Reference Manual, section 6.1.10. + Pragma Propagate_Exceptions =========================== .. index:: Interfacing to C++ 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 b0e131f..7250f65 100644 --- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst @@ -1872,7 +1872,7 @@ conventions, and for example records are laid out in a manner that is consistent with C. This means that specifying convention C (for example) has no effect. -There are four exceptions to this general rule: +There are three exceptions to this general rule: * *Convention Fortran and array subtypes*. diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst index f2fc737..6493a06 100644 --- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst +++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst @@ -2212,11 +2212,12 @@ Setting Stack Size from ``gnatlink`` You can specify the program stack size at link time. On most versions of Windows, starting with XP, this is mostly useful to set the size of the main stack (environment task). The other task stacks are set with -pragma Storage_Size or with the *gnatbind -d* command. +pragma Storage_Size or with the *gnatbind -d* command. The specified size will +become the reserved memory size of the underlying thread. Since very old versions of Windows (2000, NT4, etc.) don't allow setting the -reserve size of individual tasks, the link-time stack size applies to all -tasks, and pragma Storage_Size has no effect. +reserve size of individual tasks, for those versions the link-time stack size +applies to all tasks, and pragma Storage_Size has no effect. In particular, Stack Overflow checks are made against this link-time specified size. diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index ec1087d..15f5b99 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -1037,6 +1037,7 @@ package body Einfo.Utils is Id = Pragma_Contract_Cases or else Id = Pragma_Exceptional_Cases or else Id = Pragma_Exit_Cases or else + Id = Pragma_Program_Exit or else Id = Pragma_Subprogram_Variant or else Id = Pragma_Test_Case; diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads index ed1f153..78b4989 100644 --- a/gcc/ada/einfo-utils.ads +++ b/gcc/ada/einfo-utils.ads @@ -456,6 +456,7 @@ package Einfo.Utils is -- No_Caching -- Part_Of -- Precondition + -- Program_Exit -- Postcondition -- Refined_Depends -- Refined_Global diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index f154e7f..545c15d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -832,12 +832,6 @@ package Einfo is -- Default_Value aspect specification for the type, or inherited -- on derivation. --- Default_Expr_Function --- Defined in parameters. It holds the entity of the parameterless --- function that is built to evaluate the default expression if it is --- more complex than a simple identifier or literal. For the latter --- simple cases or if there is no default value, this field is Empty. - -- Default_Expressions_Processed -- A flag in subprograms (functions, operators, procedures) and in -- entries and entry families used to indicate that default expressions @@ -864,12 +858,6 @@ package Einfo is -- that holds value of delta for the type, as given in the declaration -- or as inherited by a subtype or derived type. --- Dependent_Instances --- Defined in packages that are instances. Holds list of instances --- of inner generics. Used to place freeze nodes for those instances --- after that of the current one, i.e. after the corresponding generic --- bodies. - -- Depends_On_Private -- Defined in all type entities. Set if the type is private or if it -- depends on a private type. @@ -1462,11 +1450,6 @@ package Einfo is -- associates generic parameters with the corresponding instances, in -- those cases where the instance is an entity. --- Handler_Records --- Defined in subprogram and package entities. Points to a list of --- identifiers referencing the handler record entities for the --- corresponding unit. - -- Has_Aliased_Components [implementation base type only] -- Defined in array type entities. Indicates that the component type -- of the array is aliased. Should this also be set for records to @@ -2262,6 +2245,11 @@ package Einfo is -- is relocated to the corresponding package body, which must have a -- corresponding nonlimited with_clause. +-- Incomplete_View +-- Defined in all entities. Present in those that are completions of +-- incomplete types. Denotes the corresponding incomplete view declared +-- by the incomplete declaration. + -- Indirect_Call_Wrapper -- Defined on subprogram entities. Set if the subprogram has class-wide -- preconditions. Denotes the internal wrapper that checks preconditions @@ -2967,6 +2955,11 @@ package Einfo is -- fully constructed, since it simply indicates the last state. -- Thus this flag has no meaning to the backend. +-- Is_Large_Unconstrained_Definite +-- Defined in record types. Used to detect types with default +-- discriminant values that have exaggerated sizes and emit warnings +-- about them. + -- Is_Limited_Composite -- Defined in all entities. Set for composite types that have a limited -- component. Used to enforce the rule that operations on the composite @@ -3638,7 +3631,7 @@ package Einfo is -- subprogram or the formal's Extra_Accessibility - whichever one is -- lesser. The Minimum_Accessibility field then points to this object. --- Modulus [base type only] +-- Modulus [implementation base type only] -- Defined in modular types. Contains the modulus. For the binary case, -- this will be a power of 2, but if Non_Binary_Modulus is set, then it -- will not be a power of 2. @@ -3658,11 +3651,6 @@ package Einfo is -- preelaborable initialization at freeze time (this has to be deferred -- to the freeze point because of the rule about overriding Initialize). --- Needs_Activation_Record --- Defined on generated subprogram types. Indicates that a call through --- a named or anonymous access to subprogram requires an activation --- record when compiling with unnesting for C or LLVM. - -- Needs_Debug_Info -- Defined in all entities. Set if the entity requires normal debugging -- information to be generated. This is true of all entities that have @@ -3904,7 +3892,7 @@ package Einfo is -- Defined in E_Access_Subprogram_Type entities. Set only if the access -- type was generated by the expander as part of processing an access- -- to-protected-subprogram type. Points to the access-to-protected- --- subprogram type. +-- subprogram type. Read by CodePeer. -- Original_Array_Type -- Defined in modular types and array types and subtypes. Set only if @@ -4176,14 +4164,6 @@ package Einfo is -- refine the state, in other words, all the hidden states that appear in -- the constituent_list of aspect/pragma Refined_State. --- Register_Exception_Call --- Defined in exception entities. When an exception is declared, --- a call is expanded to Register_Exception. This field points to --- the expanded N_Procedure_Call_Statement node for this call. It --- is used for Import/Export_Exception processing to modify the --- register call to make appropriate entries in the special tables --- used for handling these pragmas at run time. - -- Related_Array_Object -- Defined in array types and subtypes. Used only for the base type -- and subtype created for an anonymous array object. Set to point @@ -4383,11 +4363,6 @@ package Einfo is -- set, in which case this is the entity for the associated instance of -- System.Shared_Storage.Shared_Var_Procs. See Exp_Smem for full details. --- Size_Check_Code --- Defined in constants and variables. Normally Empty. Set if code is --- generated to check the size of the object. This field is used to --- suppress this code if a subsequent address clause is encountered. - -- Size_Clause (synthesized) -- Applies to all entities. If a size or value size clause is present in -- the rep item chain for an entity then that attribute definition clause @@ -5158,10 +5133,9 @@ package Einfo is -- E_Access_Subprogram_Type -- Equivalent_Type (remote types only) -- Directly_Designated_Type - -- Needs_No_Actuals -- Original_Access_Type + -- Needs_No_Actuals -- Can_Use_Internal_Rep - -- Needs_Activation_Record -- Associated_Storage_Pool $$$ -- Interface_Name $$$ -- (plus type attributes) @@ -5200,7 +5174,6 @@ package Einfo is -- Directly_Designated_Type -- Storage_Size_Variable is this needed ??? -- Can_Use_Internal_Rep - -- Needs_Activation_Record -- (plus type attributes) -- E_Anonymous_Access_Type @@ -5311,7 +5284,6 @@ package Einfo is -- Actual_Subtype -- Renamed_Object -- Renamed_Entity $$$ - -- Size_Check_Code (constants only) -- Prival_Link (privals only) -- Interface_Name (constants only) -- Related_Type (constants only) @@ -5472,7 +5444,6 @@ package Einfo is -- Esize -- Alignment -- Renamed_Entity - -- Register_Exception_Call -- Interface_Name -- Activation_Record_Component -- Discard_Names @@ -5508,7 +5479,6 @@ package Einfo is -- E_Function -- E_Generic_Function -- Mechanism (Mechanism_Type) - -- Handler_Records (non-generic case only) -- Protected_Body_Subprogram -- Next_Inlined_Subprogram -- Elaboration_Entity (not implicit /=) @@ -5662,7 +5632,6 @@ package Einfo is -- Renamed_Object -- Spec_Entity -- Default_Value - -- Default_Expr_Function -- Protected_Formal -- Extra_Constrained -- Minimum_Accessibility @@ -5773,8 +5742,6 @@ package Einfo is -- E_Package -- E_Generic_Package - -- Dependent_Instances (for an instance) - -- Handler_Records (non-generic case only) -- Generic_Homonym (generic case only) -- Associated_Formal_Package -- Elaboration_Entity @@ -5834,7 +5801,6 @@ package Einfo is -- Scope_Depth (synth) -- E_Package_Body - -- Handler_Records (non-generic case only) -- Related_Instance (non-generic case only) -- First_Entity -- Spec_Entity @@ -5869,7 +5835,6 @@ package Einfo is -- E_Procedure -- E_Generic_Procedure -- Associated_Node_For_Itype $$$ E_Procedure - -- Handler_Records (non-generic case only) -- Protected_Body_Subprogram -- Next_Inlined_Subprogram -- Elaboration_Entity @@ -6197,7 +6162,6 @@ package Einfo is -- Renamed_Object -- Renamed_Entity $$$ -- Discriminal_Link $$$ - -- Size_Check_Code -- Prival_Link -- Interface_Name -- Shared_Var_Procs_Instance @@ -6269,7 +6233,6 @@ package Einfo is -- Entry_Formal $$$ -- Esize $$$ -- First_Entity $$$ - -- Handler_Records $$$ -- Interface_Name $$$ -- Last_Entity $$$ -- Renamed_Entity $$$ diff --git a/gcc/ada/diagnostics-repository.adb b/gcc/ada/errid.adb index f01a2df..a661fcf 100644 --- a/gcc/ada/diagnostics-repository.adb +++ b/gcc/ada/errid.adb @@ -22,12 +22,23 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; -with Diagnostics.Utils; use Diagnostics.Utils; -with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; -with Output; use Output; +with JSON_Utils; use JSON_Utils; +with Output; use Output; -package body Diagnostics.Repository is +package body Errid is + + --------------- + -- To_String -- + --------------- + + function To_String (Id : Diagnostic_Id) return String is + begin + if Id = No_Diagnostic_Id then + return "GNAT0000"; + else + return Id'Img; + end if; + end To_String; --------------------------------- -- Print_Diagnostic_Repository -- @@ -119,4 +130,4 @@ package body Diagnostics.Repository is Write_Eol; end Print_Diagnostic_Repository; -end Diagnostics.Repository; +end Errid; diff --git a/gcc/ada/diagnostics-repository.ads b/gcc/ada/errid.ads index 778c991..21ef79c 100644 --- a/gcc/ada/diagnostics-repository.ads +++ b/gcc/ada/errid.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2025, Free Software Foundation, Inc. -- +-- Copyright (C) 19925, 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- -- @@ -22,7 +22,40 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -package Diagnostics.Repository is +with Types; use Types; +with Errsw; use Errsw; + +package Errid is + + type Status_Type is + (Active, + Deprecated); + + type Diagnostic_Id is + (No_Diagnostic_Id, + GNAT0001, + GNAT0002, + GNAT0003, + GNAT0004, + GNAT0005, + GNAT0006); + + function To_String (Id : Diagnostic_Id) return String; + -- Convert the diagnostic ID to a 4 character string padded with 0-s. + + type Diagnostic_Entry_Type is record + Status : Status_Type := Active; + + Human_Id : String_Ptr := null; + -- A human readable code for the diagnostic. If the diagnostic has a + -- switch with a human id then the human_id of the switch shall be used + -- in SARIF reports. + + Documentation : String_Ptr := null; + + Switch : Switch_Id := No_Switch_Id; + -- The switch that controls the diagnostic message. + end record; type Diagnostics_Registry_Type is array (Diagnostic_Id) of Diagnostic_Entry_Type; @@ -53,56 +86,26 @@ package Diagnostics.Repository is GNAT0002 => (Status => Active, Human_Id => - new String'("Invalid_Operand_Types_For_Operator_Error"), - Documentation => new String'("./error_codes/GNAT0002.md"), - Switch => No_Switch_Id), - GNAT0003 => - (Status => Active, - Human_Id => - new String'("Invalid_Operand_Types_Left_To_Int_Error"), - Documentation => new String'("./error_codes/GNAT0003.md"), - Switch => No_Switch_Id), - GNAT0004 => - (Status => Active, - Human_Id => - new String'("Invalid_Operand_Types_Right_To_Int_Error"), - Documentation => new String'("./error_codes/GNAT0004.md"), - Switch => No_Switch_Id), - GNAT0005 => - (Status => Active, - Human_Id => - new String'("Invalid_Operand_Types_Left_Acc_Error"), - Documentation => new String'("./error_codes/GNAT0005.md"), - Switch => No_Switch_Id), - GNAT0006 => - (Status => Active, - Human_Id => - new String'("Invalid_Operand_Types_Right_Acc_Error"), - Documentation => new String'("./error_codes/GNAT0006.md"), - Switch => No_Switch_Id), - GNAT0007 => - (Status => Active, - Human_Id => new String'("Invalid_Operand_Types_General_Error"), Documentation => new String'("./error_codes/GNAT0007.md"), Switch => No_Switch_Id), - GNAT0008 => + GNAT0003 => (Status => Active, Human_Id => new String'("Pragma_No_Effect_With_Lock_Free_Warning"), Documentation => new String'("./error_codes/GNAT0008.md"), Switch => No_Switch_Id), - GNAT0009 => + GNAT0004 => (Status => Active, Human_Id => new String'("End_Loop_Expected_Error"), Documentation => new String'("./error_codes/GNAT0009.md"), Switch => No_Switch_Id), - GNAT0010 => + GNAT0005 => (Status => Active, Human_Id => new String'("Representation_Too_Late_Error"), Documentation => new String'("./error_codes/GNAT0010.md"), Switch => No_Switch_Id), - GNAT0011 => + GNAT0006 => (Status => Active, Human_Id => new String'("Mixed_Container_Aggregate_Error"), Documentation => new String'("./error_codes/GNAT0011.md"), @@ -110,4 +113,4 @@ package Diagnostics.Repository is procedure Print_Diagnostic_Repository; -end Diagnostics.Repository; +end Errid; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 23c6b88..25d1d52 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -33,15 +33,18 @@ with Atree; use Atree; with Casing; use Casing; with Csets; use Csets; with Debug; use Debug; -with Diagnostics.Converter; use Diagnostics.Converter; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Erroutc; use Erroutc; +with Erroutc.Pretty_Emitter; +with Erroutc.SARIF_Emitter; +with Errsw; use Errsw; with Gnatvsn; use Gnatvsn; with Lib; use Lib; with Opt; use Opt; with Nlists; use Nlists; +with Osint; use Osint; with Output; use Output; with Scans; use Scans; with Sem_Aux; use Sem_Aux; @@ -97,10 +100,14 @@ package body Errout is ----------------------- procedure Error_Msg_Internal - (Msg : String; - Span : Source_Span; - Opan : Source_Span; - Msg_Cont : Boolean); + (Msg : String; + Span : Source_Span; + Opan : Source_Span; + Msg_Cont : Boolean; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes); -- This is the low-level routine used to post messages after dealing with -- the issue of messages placed on instantiations (which get broken up -- into separate calls in Error_Msg). Span is the location on which the @@ -285,6 +292,115 @@ package body Errout is end loop; end Delete_Warning_And_Continuations; + ------------------ + -- Labeled_Span -- + ------------------ + + function Labeled_Span + (Span : Source_Span; + Label : String := ""; + Is_Primary : Boolean := True; + Is_Region : Boolean := False) + return Labeled_Span_Type + is + L : Labeled_Span_Type; + begin + L.Span := Span; + if Label /= "" then + L.Label := new String'(Label); + end if; + L.Is_Primary := Is_Primary; + L.Is_Region := Is_Region; + L.Next := No_Labeled_Span; + + return L; + end Labeled_Span; + + -------------------------- + -- Primary_Labeled_Span -- + -------------------------- + + function Primary_Labeled_Span + (Span : Source_Span; + Label : String := "") return Labeled_Span_Type + is + begin + return Labeled_Span (Span => Span, Label => Label, Is_Primary => True); + end Primary_Labeled_Span; + + -------------------------- + -- Primary_Labeled_Span -- + -------------------------- + + function Primary_Labeled_Span + (N : Node_Or_Entity_Id; + Label : String := "") return Labeled_Span_Type + is + begin + return Primary_Labeled_Span (To_Full_Span (N), Label); + end Primary_Labeled_Span; + + ---------------------------- + -- Secondary_Labeled_Span -- + ---------------------------- + + function Secondary_Labeled_Span + (Span : Source_Span; + Label : String := "") return Labeled_Span_Type + is + begin + return Labeled_Span (Span => Span, Label => Label, Is_Primary => False); + end Secondary_Labeled_Span; + + ---------------------------- + -- Secondary_Labeled_Span -- + ---------------------------- + + function Secondary_Labeled_Span + (N : Node_Or_Entity_Id; + Label : String := "") return Labeled_Span_Type + is + begin + return Secondary_Labeled_Span (To_Full_Span (N), Label); + end Secondary_Labeled_Span; + + ---------- + -- Edit -- + ---------- + + function Edit (Text : String; Span : Source_Span) return Edit_Type is + begin + return (Text => new String'(Text), Span => Span, Next => No_Edit); + end Edit; + + --------- + -- Fix -- + --------- + + function Fix (Description : String; Edits : Edit_Array) return Fix_Type is + First_Edit : Edit_Id := No_Edit; + Last_Edit : Edit_Id := No_Edit; + begin + for I in Edits'Range loop + Erroutc.Edits.Append (Edits (I)); + + if Last_Edit /= No_Edit then + Erroutc.Edits.Table (Last_Edit).Next := Erroutc.Edits.Last; + end if; + Last_Edit := Erroutc.Edits.Last; + + -- Store the first element in the edit chain + + if First_Edit = No_Edit then + First_Edit := Last_Edit; + end if; + end loop; + + return (Description => new String'(Description), + Edits => First_Edit, + Next => No_Fix); + end Fix; + --------------- -- Error_Msg -- --------------- @@ -328,9 +444,13 @@ package body Errout is end Error_Msg; procedure Error_Msg - (Msg : String; - Flag_Span : Source_Span; - N : Node_Id) + (Msg : String; + Flag_Span : Source_Span; + N : Node_Id; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes) is Flag_Location : constant Source_Ptr := Flag_Span.Ptr; @@ -459,7 +579,15 @@ package body Errout is -- Error_Msg_Internal to place the message in the requested location. if Instantiation (Sindex) = No_Location then - Error_Msg_Internal (Msg, Flag_Span, Flag_Span, False); + Error_Msg_Internal + (Msg => Msg, + Span => Flag_Span, + Opan => Flag_Span, + Msg_Cont => False, + Error_Code => Error_Code, + Label => Label, + Spans => Spans, + Fixes => Fixes); return; end if; @@ -626,10 +754,14 @@ package body Errout is -- Here we output the original message on the outer instantiation Error_Msg_Internal - (Msg => Msg, - Span => To_Span (Actual_Error_Loc), - Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status); + (Msg => Msg, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, + Msg_Cont => Msg_Cont_Status, + Error_Code => Error_Code, + Label => Label, + Spans => Spans, + Fixes => Fixes); end; end Error_Msg; @@ -715,7 +847,7 @@ package body Errout is -- error flag in this situation. S1 := Prev_Token_Ptr; - C := Source (S1); + C := Sinput.Source (S1); -- If the previous token is a string literal, we need a special approach -- since there may be white space inside the literal and we don't want @@ -728,10 +860,10 @@ package body Errout is loop S1 := S1 + 1; - if Source (S1) = C then + if Sinput.Source (S1) = C then S1 := S1 + 1; - exit when Source (S1) /= C; - elsif Source (S1) in Line_Terminator then + exit when Sinput.Source (S1) /= C; + elsif Sinput.Source (S1) in Line_Terminator then exit; end if; end loop; @@ -749,10 +881,11 @@ package body Errout is -- characters in this context, since this is only for error recovery. else - while Source (S1) not in Line_Terminator - and then Source (S1) /= ' ' - and then Source (S1) /= ASCII.HT - and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-') + while Sinput.Source (S1) not in Line_Terminator + and then Sinput.Source (S1) /= ' ' + and then Sinput.Source (S1) /= ASCII.HT + and then (Sinput.Source (S1) /= '-' + or else Sinput.Source (S1 + 1) /= '-') and then S1 /= Token_Ptr loop S1 := S1 + 1; @@ -785,8 +918,8 @@ package body Errout is -- we would really like to place it in the "last" character of the tab -- space, but that it too much trouble to worry about). - elsif Source (Token_Ptr - 1) = ' ' - or else Source (Token_Ptr - 1) = ASCII.HT + elsif Sinput.Source (Token_Ptr - 1) = ' ' + or else Sinput.Source (Token_Ptr - 1) = ASCII.HT then Error_Msg (Msg, Token_Ptr - 1); @@ -842,13 +975,8 @@ package body Errout is ----------------- procedure Error_Msg_F (Msg : String; N : Node_Id) is - Fst, Lst : Node_Id; begin - First_And_Last_Nodes (N, Fst, Lst); - Error_Msg_NEL (Msg, N, N, - To_Span (Ptr => Sloc (Fst), - First => First_Sloc (Fst), - Last => Last_Sloc (Lst))); + Error_Msg_NEL (Msg, N, N, To_Full_Span_First (N)); end Error_Msg_F; ------------------ @@ -860,13 +988,8 @@ package body Errout is N : Node_Id; E : Node_Or_Entity_Id) is - Fst, Lst : Node_Id; begin - First_And_Last_Nodes (N, Fst, Lst); - Error_Msg_NEL (Msg, N, E, - To_Span (Ptr => Sloc (Fst), - First => First_Sloc (Fst), - Last => Last_Sloc (Lst))); + Error_Msg_NEL (Msg, N, E, To_Full_Span_First (N)); end Error_Msg_FE; ------------------------------ @@ -918,10 +1041,14 @@ package body Errout is ------------------------ procedure Error_Msg_Internal - (Msg : String; - Span : Source_Span; - Opan : Source_Span; - Msg_Cont : Boolean) + (Msg : String; + Span : Source_Span; + Opan : Source_Span; + Msg_Cont : Boolean; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes) is Sptr : constant Source_Ptr := Span.Ptr; Optr : constant Source_Ptr := Opan.Ptr; @@ -937,6 +1064,12 @@ package body Errout is Warn_Err : Boolean; -- Set if warning to be treated as error + First_Fix : Fix_Id := No_Fix; + Last_Fix : Fix_Id := No_Fix; + + Primary_Loc : Labeled_Span_Id := No_Labeled_Span; + Last_Loc : Labeled_Span_Id := No_Labeled_Span; + procedure Handle_Serious_Error; -- Internal procedure to do all error message handling for a serious -- error message, other than bumping the error counts and arranging @@ -1156,11 +1289,15 @@ package body Errout is -- Remove (style) or info: at start of message - if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then - M := 9; + if Msglen > Style_Prefix'Length + and then Msg_Buffer (1 .. Style_Prefix'Length) = Style_Prefix + then + M := Style_Prefix'Length + 1; - elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then - M := 7; + elsif Msglen > Info_Prefix'Length + and then Msg_Buffer (1 .. Info_Prefix'Length) = Info_Prefix + then + M := Info_Prefix'Length + 1; else M := 1; @@ -1226,6 +1363,37 @@ package body Errout is return; end if; + if Continuation and then Has_Insertion_Line then + Erroutc.Locations.Append + (Primary_Labeled_Span (To_Span (Error_Msg_Sloc), Label)); + else + Erroutc.Locations.Append (Primary_Labeled_Span (Span, Label)); + end if; + + Primary_Loc := Erroutc.Locations.Last; + + Last_Loc := Primary_Loc; + + for Span of Spans loop + Erroutc.Locations.Append (Span); + Erroutc.Locations.Table (Last_Loc).Next := Erroutc.Locations.Last; + Last_Loc := Erroutc.Locations.Last; + end loop; + + for Fix of Fixes loop + Erroutc.Fixes.Append (Fix); + if Last_Fix /= No_Fix then + Erroutc.Fixes.Table (Last_Fix).Next := Erroutc.Fixes.Last; + end if; + Last_Fix := Erroutc.Fixes.Last; + + -- Store the first element in the fix chain + + if First_Fix = No_Fix then + First_Fix := Last_Fix; + end if; + end loop; + -- Here we build a new error object Errors.Append @@ -1245,7 +1413,12 @@ package body Errout is Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, Deleted => False, - Kind => Error_Msg_Kind)); + Kind => Error_Msg_Kind, + Locations => Primary_Loc, + Id => Error_Code, + Switch => + Get_Switch_Id (Error_Msg_Kind, Warning_Msg_Char), + Fixes => First_Fix)); Cur_Msg := Errors.Last; -- Test if warning to be treated as error @@ -1416,33 +1589,72 @@ package body Errout is -- Error_Msg_N -- ----------------- - procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is - Fst, Lst : Node_Id; + procedure Error_Msg_N + (Msg : String; + N : Node_Or_Entity_Id; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes) + is begin - First_And_Last_Nodes (N, Fst, Lst); - Error_Msg_NEL (Msg, N, N, - To_Span (Ptr => Sloc (N), - First => First_Sloc (Fst), - Last => Last_Sloc (Lst))); + Error_Msg_NEL + (Msg => Msg, + N => N, + E => N, + Flag_Span => To_Full_Span (N), + Error_Code => Error_Code, + Label => Label, + Spans => Spans, + Fixes => Fixes); end Error_Msg_N; + ---------------------- + -- Error_Msg_N_Gigi -- + ---------------------- + + procedure Error_Msg_N_Gigi (Msg : String; N : Node_Or_Entity_Id) is + begin + Error_Msg_N (Msg, N); + end Error_Msg_N_Gigi; + ------------------ -- Error_Msg_NE -- ------------------ procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes) + is + begin + Error_Msg_NEL + (Msg => Msg, + N => N, + E => E, + Flag_Span => To_Full_Span (N), + Error_Code => Error_Code, + Label => Label, + Spans => Spans, + Fixes => Fixes); + end Error_Msg_NE; + + ----------------------- + -- Error_Msg_NE_Gigi -- + ----------------------- + + procedure Error_Msg_NE_Gigi (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id) is - Fst, Lst : Node_Id; begin - First_And_Last_Nodes (N, Fst, Lst); - Error_Msg_NEL (Msg, N, E, - To_Span (Ptr => Sloc (N), - First => First_Sloc (Fst), - Last => Last_Sloc (Lst))); - end Error_Msg_NE; + Error_Msg_NE (Msg, N, E); + end Error_Msg_NE_Gigi; ------------------- -- Error_Msg_NEL -- @@ -1465,10 +1677,14 @@ package body Errout is end Error_Msg_NEL; procedure Error_Msg_NEL - (Msg : String; - N : Node_Or_Entity_Id; - E : Node_Or_Entity_Id; - Flag_Span : Source_Span) + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Span : Source_Span; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes) is begin if Special_Msg_Delete (Msg, N, E) then @@ -1502,7 +1718,14 @@ package body Errout is then Debug_Output (N); Error_Msg_Node_1 := E; - Error_Msg (Msg, Flag_Span, N); + Error_Msg + (Msg => Msg, + Flag_Span => Flag_Span, + N => N, + Error_Code => Error_Code, + Label => Label, + Spans => Spans, + Fixes => Fixes); else Last_Killed := True; @@ -1522,17 +1745,12 @@ package body Errout is Msg : String; N : Node_Or_Entity_Id) is - Fst, Lst : Node_Id; begin if Eflag and then In_Extended_Main_Source_Unit (N) and then Comes_From_Source (N) then - First_And_Last_Nodes (N, Fst, Lst); - Error_Msg_NEL (Msg, N, N, - To_Span (Ptr => Sloc (N), - First => First_Sloc (Fst), - Last => Last_Sloc (Lst))); + Error_Msg_NEL (Msg, N, N, To_Full_Span (N)); end if; end Error_Msg_NW; @@ -2457,9 +2675,13 @@ package body Errout is Write_Str (",""option"":""" & Option & """"); end if; - -- Print message content + -- Print message content and ensure that the removed style prefix is + -- still in the message. Write_Str (",""message"":"""); + if Errors.Table (E).Kind = Style then + Write_JSON_Escaped_String (Style_Prefix); + end if; Write_JSON_Escaped_String (Errors.Table (E).Text); Write_Str (""""); @@ -2502,109 +2724,21 @@ package body Errout is procedure Write_Max_Errors; -- Write message if max errors reached - procedure Write_Source_Code_Lines - (Span : Source_Span; - SGR_Span : String); - -- Write the source code line corresponding to Span, as follows when - -- Span in on one line: - -- - -- line | actual code line here with Span somewhere - -- | ~~~~~^~~~ - -- - -- where the caret on the line points to location Span.Ptr, and the - -- range Span.First..Span.Last is underlined. - -- - -- or when the span is over multiple lines: - -- - -- line | beginning of the Span on this line - -- ... | ... - -- line>| actual code line here with Span.Ptr somewhere - -- ... | ... - -- line | end of the Span on this line - -- - -- or when the span is a simple location, as follows: - -- - -- line | actual code line here with Span somewhere - -- | ^ here - -- - -- where the caret on the line points to location Span.Ptr - -- - -- SGR_Span is the SGR string to start the section of code in the span, - -- that should be closed with SGR_Reset. - -------------------- -- Emit_Error_Msgs -- --------------------- procedure Emit_Error_Msgs is - Use_Prefix : Boolean; - E : Error_Msg_Id; + E : Error_Msg_Id; begin Set_Standard_Error; E := First_Error_Msg; while E /= No_Error_Msg loop - - -- If -gnatdF is used, separate main messages from previous - -- messages with a newline (unless it is an info message) and - -- make continuation messages follow the main message with only - -- an indentation of two space characters, without repeating - -- file:line:col: prefix. - - Use_Prefix := - not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont); - if not Errors.Table (E).Deleted then - - if Debug_Flag_FF then - if Errors.Table (E).Msg_Cont then - Write_Str (" "); - elsif Errors.Table (E).Kind /= Info then - Write_Eol; - end if; - end if; - - if Use_Prefix then - Output_Msg_Location (E); - end if; - + Output_Msg_Location (E); Output_Msg_Text (E); Write_Eol; - - -- If -gnatdF is used, write the source code line - -- corresponding to the location of the main message (unless - -- it is an info message). Also write the source code line - -- corresponding to an insertion location inside - -- continuation messages. - - if Debug_Flag_FF - and then Errors.Table (E).Kind /= Info - then - if Errors.Table (E).Msg_Cont then - declare - Loc : constant Source_Ptr := - Errors.Table (E).Insertion_Sloc; - begin - if Loc /= No_Location then - Write_Source_Code_Lines - (To_Span (Loc), SGR_Span => SGR_Note); - end if; - end; - - else - declare - SGR_Span : constant String := - (if Errors.Table (E).Kind = Info then SGR_Note - elsif Errors.Table (E).Kind = Warning - and then not Errors.Table (E).Warn_Err - then SGR_Warning - else SGR_Error); - begin - Write_Source_Code_Lines - (Errors.Table (E).Optr, SGR_Span); - end; - end if; - end if; end if; E := Errors.Table (E).Next; @@ -2664,310 +2798,18 @@ package body Errout is end if; end Write_Max_Errors; - ----------------------------- - -- Write_Source_Code_Lines -- - ----------------------------- - - procedure Write_Source_Code_Lines - (Span : Source_Span; - SGR_Span : String) - is - function Get_Line_End - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr) return Source_Ptr; - -- Get the source location for the end of the line in Buf for Loc. If - -- Loc is past the end of Buf already, return Buf'Last. - - function Get_Line_Start - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr) return Source_Ptr; - -- Get the source location for the start of the line in Buf for Loc - - function Image (X : Positive; Width : Positive) return String; - -- Output number X over Width characters, with whitespace padding. - -- Only output the low-order Width digits of X, if X is larger than - -- Width digits. - - procedure Write_Buffer - (Buf : Source_Buffer_Ptr; - First : Source_Ptr; - Last : Source_Ptr); - -- Output the characters from First to Last position in Buf, using - -- Write_Buffer_Char. - - procedure Write_Buffer_Char - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr); - -- Output the characters at position Loc in Buf, translating ASCII.HT - -- in a suitable number of spaces so that the output is not modified - -- by starting in a different column that 1. - - procedure Write_Line_Marker - (Num : Pos; - Mark : Boolean; - Width : Positive); - -- Output the line number Num over Width characters, with possibly - -- a Mark to denote the line with the main location when reporting - -- a span over multiple lines. - - ------------------ - -- Get_Line_End -- - ------------------ - - function Get_Line_End - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr) return Source_Ptr - is - Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last); - begin - while Cur_Loc < Buf'Last - and then Buf (Cur_Loc) /= ASCII.LF - loop - Cur_Loc := Cur_Loc + 1; - end loop; - - return Cur_Loc; - end Get_Line_End; - - -------------------- - -- Get_Line_Start -- - -------------------- - - function Get_Line_Start - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr) return Source_Ptr - is - Cur_Loc : Source_Ptr := Loc; - begin - while Cur_Loc > Buf'First - and then Buf (Cur_Loc - 1) /= ASCII.LF - loop - Cur_Loc := Cur_Loc - 1; - end loop; - - return Cur_Loc; - end Get_Line_Start; - - ----------- - -- Image -- - ----------- - - function Image (X : Positive; Width : Positive) return String is - Str : String (1 .. Width); - Curr : Natural := X; - begin - for J in reverse 1 .. Width loop - if Curr > 0 then - Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10); - Curr := Curr / 10; - else - Str (J) := ' '; - end if; - end loop; - - return Str; - end Image; - - ------------------ - -- Write_Buffer -- - ------------------ - - procedure Write_Buffer - (Buf : Source_Buffer_Ptr; - First : Source_Ptr; - Last : Source_Ptr) - is - begin - for Loc in First .. Last loop - Write_Buffer_Char (Buf, Loc); - end loop; - end Write_Buffer; - - ----------------------- - -- Write_Buffer_Char -- - ----------------------- - - procedure Write_Buffer_Char - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr) - is - begin - -- If the character ASCII.HT is not the last one in the file, - -- output as many spaces as the character represents in the - -- original source file. - - if Buf (Loc) = ASCII.HT - and then Loc < Buf'Last - then - for X in Get_Column_Number (Loc) .. - Get_Column_Number (Loc + 1) - 1 - loop - Write_Char (' '); - end loop; - - -- Otherwise output the character itself - - else - Write_Char (Buf (Loc)); - end if; - end Write_Buffer_Char; - - ----------------------- - -- Write_Line_Marker -- - ----------------------- - - procedure Write_Line_Marker - (Num : Pos; - Mark : Boolean; - Width : Positive) - is - begin - Write_Str (Image (Positive (Num), Width => Width)); - Write_Str ((if Mark then ">" else " ") & "|"); - end Write_Line_Marker; - - -- Local variables - - Loc : constant Source_Ptr := Span.Ptr; - Line : constant Pos := Pos (Get_Physical_Line_Number (Loc)); - - Col : constant Natural := Natural (Get_Column_Number (Loc)); - - Fst : constant Source_Ptr := Span.First; - Line_Fst : constant Pos := - Pos (Get_Physical_Line_Number (Fst)); - Col_Fst : constant Natural := - Natural (Get_Column_Number (Fst)); - Lst : constant Source_Ptr := Span.Last; - Line_Lst : constant Pos := - Pos (Get_Physical_Line_Number (Lst)); - Col_Lst : constant Natural := - Natural (Get_Column_Number (Lst)); - - Width : constant := 5; - Buf : Source_Buffer_Ptr; - Cur_Loc : Source_Ptr := Fst; - Cur_Line : Pos := Line_Fst; - - -- Start of processing for Write_Source_Code_Lines - - begin - if Loc >= First_Source_Ptr then - Buf := Source_Text (Get_Source_File_Index (Loc)); - - -- First line of the span with actual source code. We retrieve - -- the beginning of the line instead of relying on Col_Fst, as - -- ASCII.HT characters change column numbers by possibly more - -- than one. - - Write_Line_Marker - (Cur_Line, - Line_Fst /= Line_Lst and then Cur_Line = Line, - Width); - Write_Buffer (Buf, Get_Line_Start (Buf, Cur_Loc), Cur_Loc - 1); - - -- Output the first/caret/last lines of the span, as well as - -- lines that are directly above/below the caret if they complete - -- the gap with first/last lines, otherwise use ... to denote - -- intermediate lines. - - -- If the span is on one line and not a simple source location, - -- color it appropriately. - - if Line_Fst = Line_Lst - and then Col_Fst /= Col_Lst - then - Write_Str (SGR_Span); - end if; - - declare - function Do_Write_Line (Cur_Line : Pos) return Boolean is - (Cur_Line in Line_Fst | Line | Line_Lst - or else - (Cur_Line = Line_Fst + 1 and then Cur_Line = Line - 1) - or else - (Cur_Line = Line + 1 and then Cur_Line = Line_Lst - 1)); - begin - while Cur_Loc <= Buf'Last - and then Cur_Loc <= Lst - loop - if Do_Write_Line (Cur_Line) then - Write_Buffer_Char (Buf, Cur_Loc); - end if; - - if Buf (Cur_Loc) = ASCII.LF then - Cur_Line := Cur_Line + 1; - - -- Output ... for skipped lines - - if (Cur_Line = Line - and then not Do_Write_Line (Cur_Line - 1)) - or else - (Cur_Line = Line + 1 - and then not Do_Write_Line (Cur_Line)) - then - Write_Str ((1 .. Width - 3 => ' ') & "... | ..."); - Write_Eol; - end if; - - -- Display the line marker if the line should be - -- displayed. - - if Do_Write_Line (Cur_Line) then - Write_Line_Marker - (Cur_Line, - Line_Fst /= Line_Lst and then Cur_Line = Line, - Width); - end if; - end if; - - Cur_Loc := Cur_Loc + 1; - end loop; - end; - - if Line_Fst = Line_Lst - and then Col_Fst /= Col_Lst - then - Write_Str (SGR_Reset); - end if; - - -- Output the rest of the last line of the span - - Write_Buffer (Buf, Cur_Loc, Get_Line_End (Buf, Cur_Loc)); - - -- If the span is on one line, output a second line with caret - -- sign pointing to location Loc - - if Line_Fst = Line_Lst then - Write_Str (String'(1 .. Width => ' ')); - Write_Str (" |"); - Write_Str (String'(1 .. Col_Fst - 1 => ' ')); - - Write_Str (SGR_Span); - - Write_Str (String'(Col_Fst .. Col - 1 => '~')); - Write_Str ("^"); - Write_Str (String'(Col + 1 .. Col_Lst => '~')); - - -- If the span is really just a location, add the word "here" - -- to clarify this is the location for the message. - - if Col_Fst = Col_Lst then - Write_Str (" here"); - end if; - - Write_Str (SGR_Reset); - - Write_Eol; - end if; - end if; - end Write_Source_Code_Lines; - -- Local variables E : Error_Msg_Id; Err_Flag : Boolean; + Sarif_File_Name : constant String := + Get_First_Main_File_Name & ".gnat.sarif"; + Switches_File_Name : constant String := "gnat_switches.json"; + Diagnostics_File_Name : constant String := "gnat_diagnostics.json"; + + Dummy : Boolean; + -- Start of processing for Output_Messages begin @@ -3039,15 +2881,72 @@ package body Errout is -- Use updated diagnostic mechanism - if Debug_Flag_Underscore_DD then - Convert_Errors_To_Diagnostics; + if Opt.SARIF_Output then + Set_Standard_Error; + Erroutc.SARIF_Emitter.Print_SARIF_Report; + Set_Standard_Output; + + elsif Opt.SARIF_File then + System.OS_Lib.Delete_File (Sarif_File_Name, Dummy); + declare + Output_FD : + constant System.OS_Lib.File_Descriptor := + System.OS_Lib.Create_New_File + (Sarif_File_Name, Fmode => System.OS_Lib.Text); - Emit_Diagnostics; + begin + Set_Output (Output_FD); + Erroutc.SARIF_Emitter.Print_SARIF_Report; + Set_Standard_Output; + System.OS_Lib.Close (Output_FD); + end; + elsif Debug_Flag_FF then + Erroutc.Pretty_Emitter.Print_Error_Messages; else Emit_Error_Msgs; end if; end if; + if Debug_Flag_Underscore_EE then + -- Print the switch repository to a file + + System.OS_Lib.Delete_File (Switches_File_Name, Dummy); + declare + Output_FD : constant System.OS_Lib.File_Descriptor := + System.OS_Lib.Create_New_File + (Switches_File_Name, + Fmode => System.OS_Lib.Text); + + begin + Set_Output (Output_FD); + + Print_Switch_Repository; + + Set_Standard_Output; + + System.OS_Lib.Close (Output_FD); + end; + + -- Print the diagnostics repository to a file + + System.OS_Lib.Delete_File (Diagnostics_File_Name, Dummy); + declare + Output_FD : constant System.OS_Lib.File_Descriptor := + System.OS_Lib.Create_New_File + (Diagnostics_File_Name, + Fmode => System.OS_Lib.Text); + + begin + Set_Output (Output_FD); + + Print_Diagnostic_Repository; + + Set_Standard_Output; + + System.OS_Lib.Close (Output_FD); + end; + end if; + -- Full source listing case if Full_List then @@ -4056,17 +3955,45 @@ package body Errout is Msglen := 0; Flag_Source := Get_Source_File_Index (Flag); - -- Skip info: at start, we have recorded this in Error_Msg_Kind, and - -- this will be used (Info field in error message object) to put back - -- the string when it is printed. We need to do this, or we get confused + P := Text'First; + + -- Skip the continuation symbols at the start + + if P <= Text'Last and then Text (P) = '\' then + Continuation := True; + P := P + 1; + + if P <= Text'Last and then Text (P) = '\' then + Continuation_New_Line := True; + P := P + 1; + end if; + end if; + + -- Skip the message kind tokens at start since it is recorded + -- in Error_Msg_Kind, and this will be used to put back the string when + -- it is printed. We need to do this, or we get confused -- with instantiation continuations. - if Text'Length > 6 - and then Text (Text'First .. Text'First + 5) = "info: " + if Text'Length > P + Info_Prefix'Length - 1 + and then Text (P .. P + Info_Prefix'Length - 1) = Info_Prefix then - P := Text'First + 6; - else - P := Text'First; + P := P + Info_Prefix'Length; + elsif Text'Length > P + Style_Prefix'Length - 1 + and then Text (P .. P + Style_Prefix'Length - 1) = Style_Prefix + then + P := P + Style_Prefix'Length; + elsif Text'Length > P + High_Prefix'Length - 1 + and then Text (P .. P + High_Prefix'Length - 1) = High_Prefix + then + P := P + High_Prefix'Length; + elsif Text'Length > P + Medium_Prefix'Length - 1 + and then Text (P .. P + Medium_Prefix'Length - 1) = Medium_Prefix + then + P := P + Medium_Prefix'Length; + elsif Text'Length > P + Low_Prefix'Length - 1 + and then Text (P .. P + Low_Prefix'Length - 1) = Low_Prefix + then + P := P + Low_Prefix'Length; end if; -- Loop through characters of message @@ -4109,14 +4036,6 @@ package body Errout is when '#' => Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); - when '\' => - Continuation := True; - - if P <= Text'Last and then Text (P) = '\' then - Continuation_New_Line := True; - P := P + 1; - end if; - when '@' => Set_Msg_Insertion_Column; @@ -4372,6 +4291,48 @@ package body Errout is end if; end SPARK_Msg_NE; + ------------------ + -- To_Full_Span -- + ------------------ + + function To_Full_Span (N : Node_Id) return Source_Span is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (N, Fst, Lst); + return To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst)); + end To_Full_Span; + + ------------------------ + -- To_Full_Span_First -- + ------------------------ + + function To_Full_Span_First (N : Node_Id) return Source_Span is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (N, Fst, Lst); + return To_Span (Ptr => Sloc (Fst), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst)); + end To_Full_Span_First; + + ------------- + -- To_Name -- + ------------- + + function To_Name (E : Entity_Id) return String is + begin + -- The name of the node operator "&" has many special cases. Reuse the + -- node to name conversion implementation from the errout package for + -- now. + + Error_Msg_Node_1 := E; + Set_Msg_Text ("&", Sloc (E)); + + return Msg_Buffer (1 .. Msglen); + end To_Name; + -------------------------- -- Unwind_Internal_Type -- -------------------------- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 24cc1c2..98aa4b4 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -30,6 +30,7 @@ with Err_Vars; with Erroutc; +with Errid; use Errid; with Namet; use Namet; with Table; with Types; use Types; @@ -580,6 +581,19 @@ package Errout is -- client to set this to No_Error_Msg and then test it to see if a warning -- message has been issued. + subtype Labeled_Span_Type is Erroutc.Labeled_Span_Type; + subtype Fix_Type is Erroutc.Fix_Type; + subtype Edit_Type is Erroutc.Edit_Type; + + type Labeled_Span_Array is + array (Positive range <>) of Labeled_Span_Type; + type Fix_Array is array (Positive range <>) of Fix_Type; + type Edit_Array is array (Positive range <>) of Edit_Type; + + No_Locations : constant Labeled_Span_Array (1 .. 0) := (others => <>); + No_Fixes : constant Fix_Array (1 .. 0) := (others => <>); + No_Edits : constant Edit_Array (1 .. 0) := (others => <>); + procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id); -- Deletes the given warning message and all its continuations. This is -- typically used in conjunction with reading the value of Warning_Msg. @@ -713,11 +727,24 @@ package Errout is procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr; N : Node_Id); procedure Error_Msg - (Msg : String; Flag_Span : Source_Span; N : Node_Id); + (Msg : String; + Flag_Span : Source_Span; + N : Node_Id; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes); -- Output a message at specified location. Can be called from the parser -- or the semantic analyzer. If N is set, points to the relevant node for -- this message. The version with a span is preferred whenever possible, -- in other cases the version with a location can still be used. + -- + -- @param Error_Code is the unique identifier for that kind of message. + -- @param Label specifies an optional short label that will be displayed + -- under the Flag_Span. + -- @param Spans specifies other spans with labels that will be highlighted + -- in the error message. + -- @param Fixes contains a list of possible fixes for the error message. procedure Error_Msg (Msg : String; @@ -753,7 +780,13 @@ package Errout is -- Output a message at the start of the previous token. This routine can -- be called only from the parser, since it references Prev_Token_Ptr. - procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id); + procedure Error_Msg_N + (Msg : String; + N : Node_Or_Entity_Id; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes); -- Output a message at the Sloc of the given node. This routine can be -- called from the parser or the semantic analyzer, although the call from -- the latter is much more common (and is the most usual way of generating @@ -762,6 +795,9 @@ package Errout is -- suppressed if the node N already has a message posted, or if it is a -- warning and N is an entity node for which warnings are suppressed. + procedure Error_Msg_N_Gigi (Msg : String; N : Node_Or_Entity_Id); + -- This is a wrapper for the Error_Msg_N method that gets linked to gigi. + -- -- WARNING: There is a matching C declaration of this subprogram in fe.h procedure Error_Msg_F (Msg : String; N : Node_Id); @@ -771,15 +807,23 @@ package Errout is -- want for placing an error message flag in the right place. procedure Error_Msg_NE - (Msg : String; - N : Node_Or_Entity_Id; - E : Node_Or_Entity_Id); + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes); -- Output a message at the Sloc of the given node N, with an insertion of -- the name from the given entity node E. This is used by the semantic -- routines, where this is a common error message situation. The Msg text -- will contain a & or } as usual to mark the insertion point. This -- routine can be called from the parser or the analyzer. + procedure Error_Msg_NE_Gigi + (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id); + -- This is a wrapper for the Error_Msg_NE method that gets linked to gigi. + -- -- WARNING: There is a matching C declaration of this subprogram in fe.h procedure Error_Msg_FE @@ -795,10 +839,14 @@ package Errout is E : Node_Or_Entity_Id; Flag_Location : Source_Ptr); procedure Error_Msg_NEL - (Msg : String; - N : Node_Or_Entity_Id; - E : Node_Or_Entity_Id; - Flag_Span : Source_Span); + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Span : Source_Span; + Error_Code : Diagnostic_Id := No_Diagnostic_Id; + Label : String := ""; + Spans : Labeled_Span_Array := No_Locations; + Fixes : Fix_Array := No_Fixes); -- Exactly the same as Error_Msg_NE, except that the flag is placed at -- the specified Flag_Location/Flag_Span instead of at Sloc (N). @@ -827,6 +875,16 @@ package Errout is -- at the original source tree, since that's what we want for placing an -- error message flag in the right place. + function To_Full_Span (N : Node_Id) return Source_Span; + -- Creates a Source_Span by calculating the positions of its first and last + -- node contained by N in the source code and sets the span to point at the + -- location of N. + + function To_Full_Span_First (N : Node_Id) return Source_Span; + -- Creates a Source_Span by calculating the positions of its first and last + -- node contained by N in the source code and sets the span to point to the + -- starting position of the span. + function First_Node (C : Node_Id) return Node_Id; -- Return the first output of First_And_Last_Nodes @@ -966,6 +1024,32 @@ package Errout is procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg; -- Debugging routine to dump an error message + function Labeled_Span + (Span : Source_Span; + Label : String := ""; + Is_Primary : Boolean := True; + Is_Region : Boolean := False) + return Labeled_Span_Type; + -- Constructs a Labeled_Span structure with all of its attributes. + + function Primary_Labeled_Span + (Span : Source_Span; Label : String := "") return Labeled_Span_Type; + function Primary_Labeled_Span + (N : Node_Or_Entity_Id; Label : String := "") return Labeled_Span_Type; + -- Shorthand function for creating Primary Labeled_Spans + + function Secondary_Labeled_Span + (Span : Source_Span; Label : String := "") return Labeled_Span_Type; + function Secondary_Labeled_Span + (N : Node_Or_Entity_Id; Label : String := "") return Labeled_Span_Type; + -- Shorthand function for creating Secondary Labeled_Spans + + function Edit (Text : String; Span : Source_Span) return Edit_Type; + -- Constructs a Edit structure with all of its attributes. + + function Fix (Description : String; Edits : Edit_Array) return Fix_Type; + -- Constructs a Fix structure with all of its attributes. + ------------------------------------ -- SPARK Error Output Subprograms -- ------------------------------------ @@ -1028,4 +1112,8 @@ package Errout is -- Function Is_Size_Too_Small_Message tests for it by testing a prefix. -- The function and constant should be kept in synch. + function To_Name (E : Entity_Id) return String; + -- Converts an entities name into a String as if the '&' insertion + -- character was used. + end Errout; diff --git a/gcc/ada/diagnostics-pretty_emitter.adb b/gcc/ada/erroutc-pretty_emitter.adb index 6d3b908..86e2e3d 100644 --- a/gcc/ada/diagnostics-pretty_emitter.adb +++ b/gcc/ada/erroutc-pretty_emitter.adb @@ -23,12 +23,13 @@ -- -- ------------------------------------------------------------------------------ -with Diagnostics.Utils; use Diagnostics.Utils; -with Output; use Output; -with Sinput; use Sinput; -with Erroutc; use Erroutc; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sinput; use Sinput; +with GNAT.Lists; use GNAT.Lists; -package body Diagnostics.Pretty_Emitter is +package body Erroutc.Pretty_Emitter is REGION_OFFSET : constant := 1; -- Number of characters between the line bar and the region span @@ -46,17 +47,35 @@ package body Diagnostics.Pretty_Emitter is MAX_BAR_POS : constant := 7; -- The maximum position of the line bar from the start of the line + + procedure Destroy (Elem : in out Labeled_Span_Type); + pragma Inline (Destroy); + + procedure Destroy (Elem : in out Labeled_Span_Type) is + begin + -- Diagnostic elements will be freed when all the diagnostics have been + -- emitted. + null; + end Destroy; + + package Labeled_Span_Lists is new Doubly_Linked_Lists + (Element_Type => Labeled_Span_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List; + type Printable_Line is record - First : Source_Ptr; + First : Source_Ptr; -- The first character of the line - Last : Source_Ptr; + Last : Source_Ptr; -- The last character of the line Line_Nr : Pos; -- The line number - Spans : Labeled_Span_List; + Spans : Labeled_Span_List; -- The spans applied on the line end record; @@ -75,9 +94,14 @@ package body Diagnostics.Pretty_Emitter is subtype Lines_List is Lines_Lists.Doubly_Linked_List; type File_Sections is record - File : String_Ptr; + File : String_Ptr; -- Name of the file + Ptr : Source_Ptr; + -- Pointer to the Primary location in the file section that is printed + -- at the start of the file section. If there are none then the first + -- location in the section. + Lines : Lines_List; -- Lines to be printed for the file end record; @@ -86,9 +110,7 @@ package body Diagnostics.Pretty_Emitter is pragma Inline (Destroy); function Equals (L, R : File_Sections) return Boolean is - (L.File /= null - and then R.File /= null - and then L.File.all = R.File.all); + (L.File /= null and then R.File /= null and then L.File.all = R.File.all); package File_Section_Lists is new Doubly_Linked_Lists (Element_Type => File_Sections, @@ -98,8 +120,8 @@ package body Diagnostics.Pretty_Emitter is subtype File_Section_List is File_Section_Lists.Doubly_Linked_List; - function Create_File_Sections (Spans : Labeled_Span_List) - return File_Section_List; + function Create_File_Sections + (Locations : Labeled_Span_Id) return File_Section_List; -- Create a list of file sections from the labeled spans that are to be -- printed. -- @@ -107,36 +129,31 @@ package body Diagnostics.Pretty_Emitter is -- the file and the spans that are applied to each of those lines. procedure Create_File_Section - (Sections : in out File_Section_List; - Loc : Labeled_Span_Type); + (Sections : in out File_Section_List; Loc : Labeled_Span_Type); -- Create a new file section for the given labeled span. procedure Add_Printable_Line - (Lines : Lines_List; - Loc : Labeled_Span_Type; - S_Ptr : Source_Ptr); + (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr); procedure Create_Printable_Line - (Lines : Lines_List; - Loc : Labeled_Span_Type; - S_Ptr : Source_Ptr); + (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr); -- Create a new printable line for the given labeled span and add it in the -- correct position to the Lines list based on the line number. - function Has_Region_Span_Start (L : Printable_Line) return Boolean; - function Has_Region_Span_End (L : Printable_Line) return Boolean; + function Get_Region_Span + (Spans : Labeled_Span_List) return Labeled_Span_Type; function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean; - procedure Write_Region_Delimiter; + procedure Write_Region_Delimiter (SGR_Code : String); -- Write the arms signifying the start and end of a region span -- e.g. +-- - procedure Write_Region_Bar; + procedure Write_Region_Bar (SGR_Code : String); -- Write the bar signifying the continuation of a region span -- e.g. | - procedure Write_Region_Continuation; + procedure Write_Region_Continuation (SGR_Code : String); -- Write the continuation signifying the continuation of a region span -- e.g. : @@ -144,33 +161,62 @@ package body Diagnostics.Pretty_Emitter is -- Write a number of whitespaces equal to the size of the region span function Trimmed_Image (I : Natural) return String; - - procedure Write_Span_Labels (Loc : Labeled_Span_Type; - L : Printable_Line; - Line_Size : Integer; - Idx : String; - Within_Region_Span : Boolean); - - procedure Write_File_Section (Sec : File_Sections; - Write_File_Name : Boolean; - File_Name_Offset : Integer); - - procedure Write_Labeled_Spans (Spans : Labeled_Span_List; - Write_File_Name : Boolean; - File_Name_Offset : Integer); + -- Removes the leading whitespace from the 'Image of a Natural number. + + procedure Write_Span_Labels + (Loc : Labeled_Span_Type; + L : Printable_Line; + Line_Size : Integer; + Idx : String; + Within_Region_Span : Boolean; + SGR_Code : String; + Region_Span_SGR_Code : String); + + procedure Write_File_Section + (Sec : File_Sections; + Write_File_Name : Boolean; + File_Name_Offset : Integer; + Include_Spans : Boolean; + SGR_Code : String := SGR_Note); + -- Prints the labled spans for a given File_Section. + -- + -- --> <File_Section.File_Name> + -- <Labeled_Spans inside the file> + + procedure Write_Labeled_Spans + (Locations : Labeled_Span_Id; + Write_File_Name : Boolean; + File_Name_Offset : Integer; + Include_Spans : Boolean := True; + SGR_Code : String := SGR_Note); + -- Pretty-prints all of the code regions indicated by the Locations. The + -- labeled spans in the Locations are grouped by file into File_Sections + -- and sorted by the file name of the Primary location followed by all + -- other locations sorted alphabetically. procedure Write_Intersecting_Labels - (Intersecting_Labels : Labeled_Span_List); + (Intersecting_Labels : Labeled_Span_List; SGR_Code : String); + -- Prints the indices and their associated labels of intersecting labels. + -- + -- Labeled spans that are insercting on the same line are printed without + -- labels. Instead the span pointer is replaced by an index number and in + -- the end all of the indices are printed with their associated labels. + -- + -- + -- 42 | [for I in V1.First_Index .. V1.Last_Index => V1(I), -6]; + -- | ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- | 1- + -- | 2------------------------------------------- + -- | 1: positional element + -- | 2: named element function Get_Line_End - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr) return Source_Ptr; + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; -- Get the source location for the end of the line (LF) in Buf for Loc. If -- Loc is past the end of Buf already, return Buf'Last. function Get_Line_Start - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr) return Source_Ptr; + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; -- Get the source location for the start of the line in Buf for Loc function Get_First_Line_Char @@ -187,40 +233,50 @@ package body Diagnostics.Pretty_Emitter is -- Width digits. procedure Write_Buffer - (Buf : Source_Buffer_Ptr; - First : Source_Ptr; - Last : Source_Ptr); + (Buf : Source_Buffer_Ptr; First : Source_Ptr; Last : Source_Ptr); -- Output the characters from First to Last position in Buf, using -- Write_Buffer_Char. - procedure Write_Buffer_Char - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr); + procedure Write_Buffer_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr); -- Output the characters at position Loc in Buf, translating ASCII.HT -- in a suitable number of spaces so that the output is not modified -- by starting in a different column that 1. - procedure Write_Line_Marker - (Num : Pos; - Width : Positive); + procedure Write_Line_Marker (Num : Pos; Width : Positive); + -- Attempts to write the line number within Width number of whitespaces + -- followed by a bar ':' symbol. + -- + -- e.g ' 12 |' + -- + -- This is usually used on source code lines that are marked by a span. procedure Write_Empty_Bar_Line (Width : Integer); + -- Writes Width number of whitespaces and a bar '|' symbol. + -- + -- e.g ' |' + -- + -- This is usually used on lines where the label is going to printed. procedure Write_Empty_Skip_Line (Width : Integer); + -- Writes Width number of whitespaces and a bar ':' symbol. + -- + -- e.g ' :' + -- + -- This is usually used between non-continous source lines that neec to be + -- printed. - procedure Write_Error_Msg_Line (Diag : Diagnostic_Type); + procedure Write_Error_Msg_Line (E_Msg : Error_Msg_Object); -- Write the error message line for the given diagnostic: -- -- '['<Diag.Id>']' <Diag.Kind>: <Diag.Message> ['['<Diag.Switch>']'] - function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type; - Diag : Diagnostic_Type) return Boolean; + function Should_Write_File_Name + (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean; -- If the sub-diagnostic and the main diagnostic only point to the same -- file then there is no reason to add the file name to the sub-diagnostic. - function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type; - Diag : Diagnostic_Type) - return Boolean; + function Should_Write_Spans + (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean; -- Old sub-diagnostics used to have the same location as the main -- diagnostic in order to group them correctly. However in most cases -- it was not meant to point to a location but rather add an additional @@ -229,39 +285,55 @@ package body Diagnostics.Pretty_Emitter is -- If the sub-diagnostic and the main diagnostic have the same location -- then we should avoid printing the spans. - procedure Print_Edit - (Edit : Edit_Type; - Offset : Integer); + procedure Print_Diagnostic (E : Error_Msg_Id); + -- Entry point for printing a primary diagnostic message. - procedure Print_Fix - (Fix : Fix_Type; - Offset : Integer); + procedure Print_Edit (Edit : Edit_Type; Offset : Integer); + -- Prints an edit object as follows: + -- + -- --> <File_Name> + -- -<Line_Nr> <Old_Line> + -- +<Line_Nr> <New_Line> + + procedure Print_Fix (Fix : Fix_Type; Offset : Integer); + -- Prints a fix object as follows + -- + -- + Fix: <Fix.Description> + -- <Fix.Edits> procedure Print_Sub_Diagnostic - (Sub_Diag : Sub_Diagnostic_Type; - Diag : Diagnostic_Type; - Offset : Integer); + (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; Offset : Integer); + + function To_String (Sptr : Source_Ptr) return String; + -- Convert the source pointer to a string of the form: "file:line:column" + + function To_File_Name (Sptr : Source_Ptr) return String; + -- Converts the file name of the Sptr to a string. + + function Line_To_String (Sptr : Source_Ptr) return String; + -- Converts the logical line number of the Sptr to a string. + + function Column_To_String (Sptr : Source_Ptr) return String; + -- Converts the column number of the Sptr to a string. Column values less + -- than 10 are prefixed with a 0. ------------- -- Destroy -- ------------- - procedure Destroy (Elem : in out Printable_Line) - is + procedure Destroy (Elem : in out Printable_Line) is begin - -- Diagnostic elements will be freed when all the diagnostics have been - -- emitted. - null; + Labeled_Span_Lists.Destroy (Elem.Spans); end Destroy; ------------- -- Destroy -- ------------- - procedure Destroy (Elem : in out File_Sections) - is + procedure Destroy (Elem : in out File_Sections) is begin Free (Elem.File); + Lines_Lists.Destroy (Elem.Lines); end Destroy; ------------------ @@ -273,9 +345,7 @@ package body Diagnostics.Pretty_Emitter is is Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last); begin - while Cur_Loc < Buf'Last - and then Buf (Cur_Loc) /= ASCII.LF - loop + while Cur_Loc < Buf'Last and then Buf (Cur_Loc) /= ASCII.LF loop Cur_Loc := Cur_Loc + 1; end loop; @@ -291,9 +361,7 @@ package body Diagnostics.Pretty_Emitter is is Cur_Loc : Source_Ptr := Loc; begin - while Cur_Loc > Buf'First - and then Buf (Cur_Loc - 1) /= ASCII.LF - loop + while Cur_Loc > Buf'First and then Buf (Cur_Loc - 1) /= ASCII.LF loop Cur_Loc := Cur_Loc - 1; end loop; @@ -309,9 +377,7 @@ package body Diagnostics.Pretty_Emitter is is Cur_Loc : Source_Ptr := Get_Line_Start (Buf, Loc); begin - while Cur_Loc < Buf'Last - and then Buf (Cur_Loc) = ' ' - loop + while Cur_Loc < Buf'Last and then Buf (Cur_Loc) = ' ' loop Cur_Loc := Cur_Loc + 1; end loop; @@ -347,7 +413,7 @@ package body Diagnostics.Pretty_Emitter is for J in reverse 1 .. Width loop if Curr > 0 then Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10); - Curr := Curr / 10; + Curr := Curr / 10; else Str (J) := ' '; end if; @@ -360,11 +426,10 @@ package body Diagnostics.Pretty_Emitter is -- Has_Multiple_Labeled_Spans -- -------------------------------- - function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean - is + function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean is Count : Natural := 0; - Loc : Labeled_Span_Type; + Loc : Labeled_Span_Type; Loc_It : Labeled_Span_Lists.Iterator := Labeled_Span_Lists.Iterate (L.Spans); begin @@ -378,64 +443,34 @@ package body Diagnostics.Pretty_Emitter is return Count > 1; end Has_Multiple_Labeled_Spans; - --------------------------- - -- Has_Region_Span_Start -- - --------------------------- + --------------------- + -- Get_Region_Span -- + --------------------- - function Has_Region_Span_Start (L : Printable_Line) return Boolean is + function Get_Region_Span + (Spans : Labeled_Span_List) return Labeled_Span_Type + is Loc : Labeled_Span_Type; Loc_It : Labeled_Span_Lists.Iterator := - Labeled_Span_Lists.Iterate (L.Spans); - - Has_Region_Start : Boolean := False; + Labeled_Span_Lists.Iterate (Spans); begin while Labeled_Span_Lists.Has_Next (Loc_It) loop Labeled_Span_Lists.Next (Loc_It, Loc); - if not Has_Region_Start - and then Loc.Is_Region - and then L.Line_Nr = - Pos (Get_Physical_Line_Number (Loc.Span.First)) - then - Has_Region_Start := True; + if Loc.Is_Region then + return Loc; end if; end loop; - return Has_Region_Start; - end Has_Region_Span_Start; - - ------------------------- - -- Has_Region_Span_End -- - ------------------------- - - function Has_Region_Span_End (L : Printable_Line) return Boolean is - Loc : Labeled_Span_Type; - Loc_It : Labeled_Span_Lists.Iterator := - Labeled_Span_Lists.Iterate (L.Spans); - - Has_Region_End : Boolean := False; - begin - while Labeled_Span_Lists.Has_Next (Loc_It) loop - Labeled_Span_Lists.Next (Loc_It, Loc); - if not Has_Region_End - and then Loc.Is_Region - and then L.Line_Nr = - Pos (Get_Physical_Line_Number (Loc.Span.Last)) - then - Has_Region_End := True; - end if; - end loop; - return Has_Region_End; - end Has_Region_Span_End; + return No_Labeled_Span_Object; + end Get_Region_Span; ------------------ -- Write_Buffer -- ------------------ procedure Write_Buffer - (Buf : Source_Buffer_Ptr; - First : Source_Ptr; - Last : Source_Ptr) + (Buf : Source_Buffer_Ptr; First : Source_Ptr; Last : Source_Ptr) is begin for Loc in First .. Last loop @@ -447,20 +482,14 @@ package body Diagnostics.Pretty_Emitter is -- Write_Buffer_Char -- ----------------------- - procedure Write_Buffer_Char - (Buf : Source_Buffer_Ptr; - Loc : Source_Ptr) - is + procedure Write_Buffer_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) is begin -- If the character ASCII.HT is not the last one in the file, -- output as many spaces as the character represents in the -- original source file. - if Buf (Loc) = ASCII.HT - and then Loc < Buf'Last - then - for X in Get_Column_Number (Loc) .. - Get_Column_Number (Loc + 1) - 1 + if Buf (Loc) = ASCII.HT and then Loc < Buf'Last then + for X in Get_Column_Number (Loc) .. Get_Column_Number (Loc + 1) - 1 loop Write_Char (' '); end loop; @@ -476,10 +505,7 @@ package body Diagnostics.Pretty_Emitter is -- Write_Line_Marker -- ----------------------- - procedure Write_Line_Marker - (Num : Pos; - Width : Positive) - is + procedure Write_Line_Marker (Num : Pos; Width : Positive) is begin Write_Str (Image (Positive (Num), Width => Width - 2)); Write_Str (" |"); @@ -511,23 +537,27 @@ package body Diagnostics.Pretty_Emitter is -- Write_Region_Delimiter -- ---------------------------- - procedure Write_Region_Delimiter is + procedure Write_Region_Delimiter (SGR_Code : String) is begin Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (SGR_Code); Write_Str ("+"); Write_Str (String'(1 .. REGION_ARM_SIZE => '-')); + Write_Str (SGR_Reset); end Write_Region_Delimiter; ---------------------- -- Write_Region_Bar -- ---------------------- - procedure Write_Region_Bar is + procedure Write_Region_Bar (SGR_Code : String) is begin Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (SGR_Code); Write_Str ("|"); + Write_Str (SGR_Reset); Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); end Write_Region_Bar; @@ -535,11 +565,13 @@ package body Diagnostics.Pretty_Emitter is -- Write_Region_Continuation -- ------------------------------- - procedure Write_Region_Continuation is + procedure Write_Region_Continuation (SGR_Code : String) is begin Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (SGR_Code); Write_Str (":"); + Write_Str (SGR_Reset); Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); end Write_Region_Continuation; @@ -562,8 +594,8 @@ package body Diagnostics.Pretty_Emitter is Loc : Labeled_Span_Type; S_Ptr : Source_Ptr) is - L : Printable_Line; - L_It : Lines_Lists.Iterator; + L : Printable_Line; + L_It : Lines_Lists.Iterator; Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); Line_Found : Boolean := False; @@ -590,16 +622,14 @@ package body Diagnostics.Pretty_Emitter is --------------------------- procedure Create_Printable_Line - (Lines : Lines_List; - Loc : Labeled_Span_Type; - S_Ptr : Source_Ptr) + (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr) is Spans : constant Labeled_Span_List := Labeled_Span_Lists.Create; Buf : constant Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (S_Ptr)); - Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); + Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); New_Line : constant Printable_Line := (First => Get_Line_Start (Buf, S_Ptr), @@ -620,9 +650,7 @@ package body Diagnostics.Pretty_Emitter is while Lines_Lists.Has_Next (L_It) loop Lines_Lists.Next (L_It, L); - if not Found_Greater_Line - and then L.Line_Nr > New_Line.Line_Nr - then + if not Found_Greater_Line and then L.Line_Nr > New_Line.Line_Nr then Found_Greater_Line := True; Insert_Before_Line := L; @@ -630,13 +658,10 @@ package body Diagnostics.Pretty_Emitter is end if; end loop; - if Found_Greater_Line then - - -- Insert after all the lines have been iterated over to avoid the - -- mutation lock in GNAT.Lists + -- Insert after all the lines have been iterated over to avoid the + -- mutation lock in GNAT.Lists. - null; - else + if not Found_Greater_Line then Lines_Lists.Append (Lines, New_Line); end if; end Create_Printable_Line; @@ -652,15 +677,15 @@ package body Diagnostics.Pretty_Emitter is -- Carret positions Ptr : constant Source_Ptr := Loc.Span.Ptr; - Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr)); + Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr)); -- Span start positions Fst : constant Source_Ptr := Loc.Span.First; - Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst)); + Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst)); -- Span end positions Lst : constant Source_Ptr := Loc.Span.Last; - Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst)); + Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst)); begin Create_Printable_Line (Lines, Loc, Fst); @@ -675,6 +700,7 @@ package body Diagnostics.Pretty_Emitter is File_Section_Lists.Append (Sections, (File => new String'(To_File_Name (Loc.Span.Ptr)), + Ptr => Loc.Span.Ptr, Lines => Lines)); end Create_File_Section; @@ -683,11 +709,10 @@ package body Diagnostics.Pretty_Emitter is -------------------------- function Create_File_Sections - (Spans : Labeled_Span_List) return File_Section_List + (Locations : Labeled_Span_Id) return File_Section_List is Loc : Labeled_Span_Type; - Loc_It : Labeled_Span_Lists.Iterator := - Labeled_Span_Lists.Iterate (Spans); + Loc_It : Labeled_Span_Id := Locations; Sections : File_Section_List := File_Section_Lists.Create; @@ -696,8 +721,8 @@ package body Diagnostics.Pretty_Emitter is File_Found : Boolean; begin - while Labeled_Span_Lists.Has_Next (Loc_It) loop - Labeled_Span_Lists.Next (Loc_It, Loc); + while Loc_It /= No_Labeled_Span loop + Loc := Erroutc.Locations.Table (Loc_It); File_Found := False; F_It := File_Section_Lists.Iterate (Sections); @@ -711,16 +736,20 @@ package body Diagnostics.Pretty_Emitter is File_Found := True; Add_Printable_Line (Sec.Lines, Loc, Loc.Span.First); - Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Ptr); - Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Last); + + if Loc.Is_Primary then + Sec.Ptr := Loc.Span.Ptr; + end if; end if; end loop; if not File_Found then Create_File_Section (Sections, Loc); end if; + + Loc_It := Loc.Next; end loop; return Sections; @@ -730,21 +759,24 @@ package body Diagnostics.Pretty_Emitter is -- Write_Span_Labels -- ----------------------- - procedure Write_Span_Labels (Loc : Labeled_Span_Type; - L : Printable_Line; - Line_Size : Integer; - Idx : String; - Within_Region_Span : Boolean) + procedure Write_Span_Labels + (Loc : Labeled_Span_Type; + L : Printable_Line; + Line_Size : Integer; + Idx : String; + Within_Region_Span : Boolean; + SGR_Code : String; + Region_Span_SGR_Code : String) is Span_Char : constant Character := (if Loc.Is_Primary then '~' else '-'); Buf : constant Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (L.First)); - Col_L_Fst : constant Natural := Natural - (Get_Column_Number (Get_First_Line_Char (Buf, L.First))); - Col_L_Lst : constant Natural := Natural - (Get_Column_Number (Get_Last_Line_Char (Buf, L.Last))); + Col_L_Fst : constant Natural := + Natural (Get_Column_Number (Get_First_Line_Char (Buf, L.First))); + Col_L_Lst : constant Natural := + Natural (Get_Column_Number (Get_Last_Line_Char (Buf, L.Last))); -- Carret positions Ptr : constant Source_Ptr := Loc.Span.Ptr; @@ -775,8 +807,7 @@ package body Diagnostics.Pretty_Emitter is (if Line_Ptr = L.Line_Nr then Col_Ptr else Col_L_Fst); Span_Ptr_Lst : constant Natural := - (if Line_Ptr = L.Line_Nr - then Span_Ptr_Fst + Span_Sym'Length + (if Line_Ptr = L.Line_Nr then Span_Ptr_Fst + Span_Sym'Length else Span_Fst); begin @@ -784,13 +815,15 @@ package body Diagnostics.Pretty_Emitter is Write_Empty_Bar_Line (Line_Size); if Within_Region_Span then - Write_Region_Bar; + Write_Region_Bar (Region_Span_SGR_Code); else Write_Region_Offset; end if; Write_Str (String'(1 .. Span_Fst - 1 => ' ')); + Write_Str (SGR_Code); + if Line_Ptr = L.Line_Nr then Write_Str (String'(Span_Fst .. Col_Ptr - 1 => Span_Char)); Write_Str (Span_Sym); @@ -798,6 +831,8 @@ package body Diagnostics.Pretty_Emitter is Write_Str (String'(Span_Ptr_Lst .. Span_Lst => Span_Char)); + Write_Str (SGR_Reset); + Write_Eol; -- Write the label under the line unless it is an intersecting span. @@ -808,24 +843,27 @@ package body Diagnostics.Pretty_Emitter is Write_Empty_Bar_Line (Line_Size); if Within_Region_Span then - Write_Region_Bar; + Write_Region_Bar (Region_Span_SGR_Code); else Write_Region_Offset; end if; Write_Str (String'(1 .. Span_Fst - 1 => ' ')); + Write_Str (SGR_Code); Write_Str (Loc.Label.all); + Write_Str (SGR_Reset); Write_Eol; end if; else if Line_Lst = L.Line_Nr then Write_Empty_Bar_Line (Line_Size); Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (SGR_Code); Write_Str (Loc.Label.all); + Write_Str (SGR_Reset); Write_Eol; end if; end if; - end Write_Span_Labels; ------------------- @@ -833,7 +871,7 @@ package body Diagnostics.Pretty_Emitter is ------------------- function Trimmed_Image (I : Natural) return String is - Img_Raw : constant String := Natural'Image (I); + Img_Raw : constant String := Natural'Image (I); begin return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); end Trimmed_Image; @@ -843,22 +881,24 @@ package body Diagnostics.Pretty_Emitter is ------------------------------- procedure Write_Intersecting_Labels - (Intersecting_Labels : Labeled_Span_List) + (Intersecting_Labels : Labeled_Span_List; SGR_Code : String) is - Ls : Labeled_Span_Type; - Ls_It : Labeled_Span_Lists.Iterator := + L : Labeled_Span_Type; + L_It : Labeled_Span_Lists.Iterator := Labeled_Span_Lists.Iterate (Intersecting_Labels); - Idx : Integer := 0; + Idx : Integer := 0; begin - while Labeled_Span_Lists.Has_Next (Ls_It) loop - Labeled_Span_Lists.Next (Ls_It, Ls); + while Labeled_Span_Lists.Has_Next (L_It) loop + Labeled_Span_Lists.Next (L_It, L); Idx := Idx + 1; Write_Empty_Bar_Line (MAX_BAR_POS); Write_Str (" "); + Write_Str ((if L.Is_Primary then SGR_Code else SGR_Note)); Write_Int (Int (Idx)); Write_Str (": "); - Write_Str (Ls.Label.all); + Write_Str (L.Label.all); + Write_Str (SGR_Reset); Write_Eol; end loop; end Write_Intersecting_Labels; @@ -867,18 +907,18 @@ package body Diagnostics.Pretty_Emitter is -- Write_File_Section -- ------------------------ - procedure Write_File_Section (Sec : File_Sections; - Write_File_Name : Boolean; - File_Name_Offset : Integer) + procedure Write_File_Section + (Sec : File_Sections; Write_File_Name : Boolean; + File_Name_Offset : Integer; Include_Spans : Boolean; + SGR_Code : String := SGR_Note) is use Lines_Lists; - L : Printable_Line; - L_It : Iterator := Iterate (Sec.Lines); + function Get_SGR_Code (L : Labeled_Span_Type) return String is + (if L.Is_Primary then SGR_Code else SGR_Note); - -- The error should be included in the first (primary) span of the file. - Loc : constant Labeled_Span_Type := - Labeled_Span_Lists.First (Lines_Lists.First (Sec.Lines).Spans); + L : Printable_Line; + L_It : Iterator := Iterate (Sec.Lines); Multiple_Labeled_Spans : Boolean := False; @@ -896,45 +936,62 @@ package body Diagnostics.Pretty_Emitter is -- offset the file start location for sub-diagnostics Write_Str (String'(1 .. File_Name_Offset => ' ')); - Write_Str ("--> " & To_String (Loc.Span.Ptr)); + Write_Str ("--> " & To_String (Sec.Ptr)); Write_Eol; end if; + -- Historically SPARK does not include spans in their info messages. + + if not Include_Spans then + return; + end if; + while Has_Next (L_It) loop Next (L_It, L); declare - Line_Nr : constant Pos := L.Line_Nr; + Line_Nr : constant Pos := L.Line_Nr; Line_Str : constant String := Trimmed_Image (Natural (Line_Nr)); Line_Size : constant Integer := Integer'Max (Line_Str'Length, MAX_BAR_POS); - Loc : Labeled_Span_Type; + Loc : Labeled_Span_Type; Loc_It : Labeled_Span_Lists.Iterator := Labeled_Span_Lists.Iterate (L.Spans); Buf : constant Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (L.First)); + Region_Span : constant Labeled_Span_Type := + Get_Region_Span (L.Spans); + Contains_Region_Span_Start : constant Boolean := - Has_Region_Span_Start (L); + Region_Span /= No_Labeled_Span_Object + and then Line_Nr = + Pos (Get_Physical_Line_Number (Region_Span.Span.First)); Contains_Region_Span_End : constant Boolean := - Has_Region_Span_End (L); + Region_Span /= No_Labeled_Span_Object + and then Line_Nr = + Pos (Get_Physical_Line_Number (Region_Span.Span.Last)); + + Region_Span_Color : constant String := + (if Region_Span /= No_Labeled_Span_Object then + Get_SGR_Code (Region_Span) + else SGR_Note); begin if not Multiple_Labeled_Spans then - Multiple_Labeled_Spans := Has_Multiple_Labeled_Spans (L); + Multiple_Labeled_Spans := Has_Multiple_Labeled_Spans (L); end if; -- Write an empty line with the continuation symbol if the line -- numbers are not contiguous - if Prev_Line_Nr /= 0 - and then Pos (Prev_Line_Nr + 1) /= Line_Nr + if Prev_Line_Nr /= 0 and then Pos (Prev_Line_Nr + 1) /= Line_Nr then Write_Empty_Skip_Line (Line_Size); if Within_Region_Span then - Write_Region_Continuation; + Write_Region_Continuation (Region_Span_Color); end if; Write_Eol; @@ -950,28 +1007,23 @@ package body Diagnostics.Pretty_Emitter is -- whitespaces. if Contains_Region_Span_Start or Contains_Region_Span_End then - Write_Region_Delimiter; + Write_Region_Delimiter (Region_Span_Color); elsif Within_Region_Span then - Write_Region_Bar; + Write_Region_Bar (Region_Span_Color); else Write_Region_Offset; end if; -- Write the line itself - Write_Buffer - (Buf => Buf, - First => L.First, - Last => L.Last); + Write_Buffer (Buf => Buf, First => L.First, Last => L.Last); -- Write all the spans for the line while Labeled_Span_Lists.Has_Next (Loc_It) loop Labeled_Span_Lists.Next (Loc_It, Loc); - if Multiple_Labeled_Spans - and then Loc.Label /= null - then + if Multiple_Labeled_Spans and then Loc.Label /= null then -- Collect all the spans with labels to print them at the -- end. @@ -980,17 +1032,23 @@ package body Diagnostics.Pretty_Emitter is Idx := Idx + 1; - Write_Span_Labels (Loc, - L, - Line_Size, - Trimmed_Image (Idx), - Within_Region_Span); + Write_Span_Labels + (Loc => Loc, + L => L, + Line_Size => Line_Size, + Idx => Trimmed_Image (Idx), + Within_Region_Span => Within_Region_Span, + SGR_Code => Get_SGR_Code (Loc), + Region_Span_SGR_Code => Region_Span_Color); else - Write_Span_Labels (Loc, - L, - Line_Size, - "", - Within_Region_Span); + Write_Span_Labels + (Loc => Loc, + L => L, + Line_Size => Line_Size, + Idx => "", + Within_Region_Span => Within_Region_Span, + SGR_Code => Get_SGR_Code (Loc), + Region_Span_SGR_Code => Region_Span_Color); end if; end loop; @@ -1003,18 +1061,21 @@ package body Diagnostics.Pretty_Emitter is end; end loop; - Write_Intersecting_Labels (Intersecting_Labels); + Write_Intersecting_Labels (Intersecting_Labels, SGR_Code); end Write_File_Section; ------------------------- -- Write_Labeled_Spans -- ------------------------- - procedure Write_Labeled_Spans (Spans : Labeled_Span_List; - Write_File_Name : Boolean; - File_Name_Offset : Integer) + procedure Write_Labeled_Spans + (Locations : Labeled_Span_Id; + Write_File_Name : Boolean; + File_Name_Offset : Integer; + Include_Spans : Boolean := True; + SGR_Code : String := SGR_Note) is - Sections : File_Section_List := Create_File_Sections (Spans); + Sections : File_Section_List := Create_File_Sections (Locations); Sec : File_Sections; F_It : File_Section_Lists.Iterator := @@ -1024,7 +1085,11 @@ package body Diagnostics.Pretty_Emitter is File_Section_Lists.Next (F_It, Sec); Write_File_Section - (Sec, Write_File_Name, File_Name_Offset); + (Sec => Sec, + Write_File_Name => Write_File_Name, + File_Name_Offset => File_Name_Offset, + Include_Spans => Include_Spans, + SGR_Code => SGR_Code); end loop; File_Section_Lists.Destroy (Sections); @@ -1034,32 +1099,28 @@ package body Diagnostics.Pretty_Emitter is -- Write_Error_Msg_Line -- -------------------------- - procedure Write_Error_Msg_Line (Diag : Diagnostic_Type) is - Switch_Str : constant String := Get_Doc_Switch (Diag); - - Kind_Str : constant String := Kind_To_String (Diag); + procedure Write_Error_Msg_Line (E_Msg : Error_Msg_Object) is + Switch_Str : constant String := Get_Doc_Switch (E_Msg); - SGR_Code : constant String := - (if Kind_Str = "error" then SGR_Error - elsif Kind_Str = "warning" then SGR_Warning - elsif Kind_Str = "info" then SGR_Note - else SGR_Reset); + SGR_Code : constant String := Get_SGR_Code (E_Msg); begin Write_Str (SGR_Code); - Write_Str ("[" & To_String (Diag.Id) & "]"); + if not GNATprove_Mode or else E_Msg.Id /= No_Diagnostic_Id then + Write_Str ("[" & To_String (E_Msg.Id) & "]"); + end if; - Write_Str (" " & Kind_To_String (Diag) & ": "); + Write_Str (" " & Kind_To_String (E_Msg) & ": "); Write_Str (SGR_Reset); - Write_Str (Diag.Message.all); + Write_Str (E_Msg.Text.all); if Switch_Str /= "" then Write_Str (" " & Switch_Str); end if; - if Diag.Warn_Err then + if E_Msg.Warn_Err then Write_Str (" [warning-as-error]"); end if; @@ -1070,44 +1131,49 @@ package body Diagnostics.Pretty_Emitter is -- Should_Write_File_Name -- ---------------------------- - function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type; - Diag : Diagnostic_Type) - return Boolean + function Should_Write_File_Name + (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean is - Sub_Loc : constant Labeled_Span_Type := Primary_Location (Sub_Diag); - Diag_Loc : constant Labeled_Span_Type := Primary_Location (Diag); + Sub_Loc : constant Labeled_Span_Type := + Locations.Table (Primary_Location (Sub_Diag)); + + Diag_Loc : constant Labeled_Span_Type := + Locations.Table (Primary_Location (Diag)); - function Has_Multiple_Files (Spans : Labeled_Span_List) return Boolean; + function Has_Multiple_Files (Diag : Error_Msg_Object) return Boolean; ------------------------ -- Has_Multiple_Files -- ------------------------ - function Has_Multiple_Files - (Spans : Labeled_Span_List) return Boolean - is + function Has_Multiple_Files (Diag : Error_Msg_Object) return Boolean is First : constant Labeled_Span_Type := - Labeled_Span_Lists.First (Spans); + Locations.Table (Diag.Locations); File : constant String := To_File_Name (First.Span.Ptr); - Loc : Labeled_Span_Type; - It : Labeled_Span_Lists.Iterator := - Labeled_Span_Lists.Iterate (Spans); - + Loc_Id : Labeled_Span_Id := Diag.Locations; + Loc : Labeled_Span_Type; begin - while Labeled_Span_Lists.Has_Next (It) loop - Labeled_Span_Lists.Next (It, Loc); + Loc_Id := Diag.Locations; + while Loc_Id /= No_Labeled_Span loop + Loc := Locations.Table (Loc_Id); if To_File_Name (Loc.Span.Ptr) /= File then return True; end if; + + Loc_Id := Loc.Next; end loop; + return False; end Has_Multiple_Files; + + -- Start of processing for Should_Write_File_Name + begin return - Has_Multiple_Files (Diag.Locations) + Has_Multiple_Files (Diag) or else To_File_Name (Sub_Loc.Span.Ptr) /= To_File_Name (Diag_Loc.Span.Ptr); end Should_Write_File_Name; @@ -1116,16 +1182,16 @@ package body Diagnostics.Pretty_Emitter is -- Should_Write_Spans -- ------------------------ - function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type; - Diag : Diagnostic_Type) - return Boolean + function Should_Write_Spans + (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean is - Sub_Loc : constant Labeled_Span_Type := Primary_Location (Sub_Diag); - Diag_Loc : constant Labeled_Span_Type := Primary_Location (Diag); + Sub_Loc : constant Labeled_Span_Id := Primary_Location (Sub_Diag); + Diag_Loc : constant Labeled_Span_Id := Primary_Location (Diag); begin - return Sub_Loc /= No_Labeled_Span - and then Diag_Loc /= No_Labeled_Span - and then Sub_Loc.Span.Ptr /= Diag_Loc.Span.Ptr; + return + Sub_Loc /= No_Labeled_Span and then Diag_Loc /= No_Labeled_Span + and then Locations.Table (Sub_Loc).Span.Ptr /= + Locations.Table (Diag_Loc).Span.Ptr; end Should_Write_Spans; ---------------- @@ -1134,7 +1200,7 @@ package body Diagnostics.Pretty_Emitter is procedure Print_Edit (Edit : Edit_Type; Offset : Integer) is Buf : constant Source_Buffer_Ptr := - Source_Text (Get_Source_File_Index (Edit.Span.Ptr)); + Source_Text (Get_Source_File_Index (Edit.Span.Ptr)); Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (Edit.Span.Ptr)); @@ -1150,10 +1216,7 @@ package body Diagnostics.Pretty_Emitter is Write_Char ('-'); Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1); - Write_Buffer - (Buf => Buf, - First => Line_Fst, - Last => Line_Lst); + Write_Buffer (Buf => Buf, First => Line_Fst, Last => Line_Lst); -- write the edited line @@ -1161,19 +1224,13 @@ package body Diagnostics.Pretty_Emitter is Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1); Write_Buffer - (Buf => Buf, - First => Line_Fst, - Last => Edit.Span.First - 1); + (Buf => Buf, First => Line_Fst, Last => Edit.Span.First - 1); if Edit.Text /= null then Write_Str (Edit.Text.all); end if; - Write_Buffer - (Buf => Buf, - First => Edit.Span.Last + 1, - Last => Line_Lst); - + Write_Buffer (Buf => Buf, First => Edit.Span.Last + 1, Last => Line_Lst); end Print_Edit; --------------- @@ -1181,7 +1238,7 @@ package body Diagnostics.Pretty_Emitter is --------------- procedure Print_Fix (Fix : Fix_Type; Offset : Integer) is - use Edit_Lists; + E : Edit_Id; begin Write_Str (String'(1 .. Offset => ' ')); Write_Str ("+ Fix: "); @@ -1191,19 +1248,12 @@ package body Diagnostics.Pretty_Emitter is end if; Write_Eol; - if Present (Fix.Edits) then - declare - Edit : Edit_Type; - - It : Iterator := Iterate (Fix.Edits); - begin - while Has_Next (It) loop - Next (It, Edit); + E := Fix.Edits; + while E /= No_Edit loop + Print_Edit (Edits.Table (E), MAX_BAR_POS - 1); - Print_Edit (Edit, MAX_BAR_POS - 1); - end loop; - end; - end if; + E := Edits.Table (E).Next; + end loop; end Print_Fix; -------------------------- @@ -1211,26 +1261,23 @@ package body Diagnostics.Pretty_Emitter is -------------------------- procedure Print_Sub_Diagnostic - (Sub_Diag : Sub_Diagnostic_Type; - Diag : Diagnostic_Type; - Offset : Integer) + (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; Offset : Integer) is begin Write_Str (String'(1 .. Offset => ' ')); - if Sub_Diag.Kind = Suggestion then - Write_Str ("+ Suggestion: "); - else - Write_Str ("+ "); - end if; + Write_Str ("+ "); - Write_Str (Sub_Diag.Message.all); + Write_Str (Sub_Diag.Text.all); Write_Eol; if Should_Write_Spans (Sub_Diag, Diag) then - Write_Labeled_Spans (Sub_Diag.Locations, - Should_Write_File_Name (Sub_Diag, Diag), - Offset); + Write_Labeled_Spans + (Locations => Sub_Diag.Locations, + Write_File_Name => Should_Write_File_Name (Sub_Diag, Diag), + File_Name_Offset => Offset, + Include_Spans => not GNATprove_Mode or else Sub_Diag.Kind /= Info, + SGR_Code => SGR_Note); end if; end Print_Sub_Diagnostic; @@ -1238,57 +1285,126 @@ package body Diagnostics.Pretty_Emitter is -- Print_Diagnostic -- ---------------------- - procedure Print_Diagnostic (Diag : Diagnostic_Type) is + procedure Print_Diagnostic (E : Error_Msg_Id) is + E_Msg : constant Error_Msg_Object := Errors.Table (E); + + E_Next_Id : Error_Msg_Id; + F : Fix_Id; begin -- Print the main diagnostic - Write_Error_Msg_Line (Diag); + Write_Error_Msg_Line (E_Msg); -- Print diagnostic locations along with spans - Write_Labeled_Spans (Diag.Locations, True, 0); + Write_Labeled_Spans + (Locations => E_Msg.Locations, + Write_File_Name => True, + File_Name_Offset => 0, + Include_Spans => not GNATprove_Mode or else E_Msg.Kind /= Info, + SGR_Code => Get_SGR_Code (E_Msg)); -- Print subdiagnostics - if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then - declare - use Sub_Diagnostic_Lists; - Sub_Diag : Sub_Diagnostic_Type; - - It : Iterator := Iterate (Diag.Sub_Diagnostics); - begin - while Has_Next (It) loop - Next (It, Sub_Diag); - - -- Print the subdiagnostic and offset the location of the file - -- name + E_Next_Id := E_Msg.Next; + while E_Next_Id /= No_Error_Msg + and then Errors.Table (E_Next_Id).Msg_Cont + loop + -- Print the subdiagnostic and offset the location of the file + -- name + Print_Sub_Diagnostic + (Errors.Table (E_Next_Id), E_Msg, MAX_BAR_POS - 1); - Print_Sub_Diagnostic (Sub_Diag, Diag, MAX_BAR_POS - 1); - end loop; - end; - end if; + E_Next_Id := Errors.Table (E_Next_Id).Next; + end loop; -- Print fixes - if Fix_Lists.Present (Diag.Fixes) then - declare - use Fix_Lists; - Fix : Fix_Type; - - It : Iterator := Iterate (Diag.Fixes); - begin - while Has_Next (It) loop - Next (It, Fix); + F := E_Msg.Fixes; + while F /= No_Fix loop + Print_Fix (Fixes.Table (F), MAX_BAR_POS - 1); - Print_Fix (Fix, MAX_BAR_POS - 1); - end loop; - end; - end if; + F := Fixes.Table (F).Next; + end loop; -- Separate main diagnostics with a blank line Write_Eol; - end Print_Diagnostic; -end Diagnostics.Pretty_Emitter; + + -------------------------- + -- Print_Error_Messages -- + -------------------------- + + procedure Print_Error_Messages is + E : Error_Msg_Id; + begin + Set_Standard_Error; + + E := First_Error_Msg; + while E /= No_Error_Msg loop + + if not Errors.Table (E).Deleted and then not Errors.Table (E).Msg_Cont + then + Print_Diagnostic (E); + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end Print_Error_Messages; + + ------------------ + -- To_File_Name -- + ------------------ + + function To_File_Name (Sptr : Source_Ptr) return String is + Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr); + Ref_Name : constant File_Name_Type := + (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile) + else Reference_Name (Sfile)); + + begin + return Get_Name_String (Ref_Name); + end To_File_Name; + + -------------------- + -- Line_To_String -- + -------------------- + + function Line_To_String (Sptr : Source_Ptr) return String is + Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr); + Img_Raw : constant String := Int'Image (Int (Line)); + + begin + return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Line_To_String; + + ---------------------- + -- Column_To_String -- + ---------------------- + + function Column_To_String (Sptr : Source_Ptr) return String is + Col : constant Column_Number := Get_Column_Number (Sptr); + Img_Raw : constant String := Int'Image (Int (Col)); + + begin + return + (if Col < 10 then "0" else "") & + Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Column_To_String; + + --------------- + -- To_String -- + --------------- + + function To_String (Sptr : Source_Ptr) return String is + begin + return + To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" & + Column_To_String (Sptr); + end To_String; + +end Erroutc.Pretty_Emitter; diff --git a/gcc/ada/diagnostics-pretty_emitter.ads b/gcc/ada/erroutc-pretty_emitter.ads index 2f5ba04..3ff0109 100644 --- a/gcc/ada/diagnostics-pretty_emitter.ads +++ b/gcc/ada/erroutc-pretty_emitter.ads @@ -23,6 +23,6 @@ -- -- ------------------------------------------------------------------------------ -package Diagnostics.Pretty_Emitter is - procedure Print_Diagnostic (Diag : Diagnostic_Type); -end Diagnostics.Pretty_Emitter; +package Erroutc.Pretty_Emitter is + procedure Print_Error_Messages; +end Erroutc.Pretty_Emitter; diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/erroutc-sarif_emitter.adb index 31b3154..791becb 100644 --- a/gcc/ada/diagnostics-sarif_emitter.adb +++ b/gcc/ada/erroutc-sarif_emitter.adb @@ -23,29 +23,104 @@ -- -- ------------------------------------------------------------------------------ -with Diagnostics.Utils; use Diagnostics.Utils; -with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; -with Gnatvsn; use Gnatvsn; -with Output; use Output; -with Sinput; use Sinput; -with Lib; use Lib; -with Namet; use Namet; -with Osint; use Osint; -with Errout; use Errout; - -package body Diagnostics.SARIF_Emitter is +with JSON_Utils; use JSON_Utils; +with GNAT.Lists; use GNAT.Lists; +with Gnatvsn; use Gnatvsn; +with Lib; use Lib; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Sinput; use Sinput; +with System.OS_Lib; + +package body Erroutc.SARIF_Emitter is + + -- SARIF attribute names + + N_ARTIFACT_CHANGES : constant String := "artifactChanges"; + N_ARTIFACT_LOCATION : constant String := "artifactLocation"; + N_COMMAND_LINE : constant String := "commandLine"; + N_DELETED_REGION : constant String := "deletedRegion"; + N_DESCRIPTION : constant String := "description"; + N_DRIVER : constant String := "driver"; + N_END_COLUMN : constant String := "endColumn"; + N_END_LINE : constant String := "endLine"; + N_EXECUTION_SUCCESSFUL : constant String := "executionSuccessful"; + N_FIXES : constant String := "fixes"; + N_ID : constant String := "id"; + N_INSERTED_CONTENT : constant String := "insertedContent"; + N_INVOCATIONS : constant String := "invocations"; + N_LOCATIONS : constant String := "locations"; + N_LEVEL : constant String := "level"; + N_MESSAGE : constant String := "message"; + N_NAME : constant String := "name"; + N_ORIGINAL_URI_BASE_IDS : constant String := "originalUriBaseIds"; + N_PHYSICAL_LOCATION : constant String := "physicalLocation"; + N_REGION : constant String := "region"; + N_RELATED_LOCATIONS : constant String := "relatedLocations"; + N_REPLACEMENTS : constant String := "replacements"; + N_RESULTS : constant String := "results"; + N_RULES : constant String := "rules"; + N_RULE_ID : constant String := "ruleId"; + N_RUNS : constant String := "runs"; + N_SCHEMA : constant String := "$schema"; + N_START_COLUMN : constant String := "startColumn"; + N_START_LINE : constant String := "startLine"; + N_TEXT : constant String := "text"; + N_TOOL : constant String := "tool"; + N_URI : constant String := "uri"; + N_URI_BASE_ID : constant String := "uriBaseId"; + N_VERSION : constant String := "version"; -- We are currently using SARIF 2.1.0 SARIF_Version : constant String := "2.1.0"; pragma Style_Checks ("M100"); - SARIF_Schema : constant String := + SARIF_Schema : constant String := "https://docs.oasis-open.org/sarif/sarif/v2.1.0/errata01/os/schemas/sarif-schema-2.1.0.json"; pragma Style_Checks ("M79"); + URI_Base_Id_Name : constant String := "PWD"; + -- We use the pwd as the originalUriBaseIds when providing absolute paths + -- in locations. + + Current_Dir : constant String := Get_Current_Dir; + -- Cached value of the current directory that is used in the URI_Base_Id + -- and it is also the path that all other Uri attributes will be created + -- relative to. + + procedure Destroy (Elem : in out Error_Msg_Object) is null; + pragma Inline (Destroy); + package Error_Msg_Lists is new Doubly_Linked_Lists + (Element_Type => Error_Msg_Object, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Error_Msg_List is Error_Msg_Lists.Doubly_Linked_List; + + procedure Destroy (Elem : in out Edit_Type); + + procedure Destroy (Elem : in out Edit_Type) is + begin + -- Diagnostic elements will be freed when all the diagnostics have been + -- emitted. + null; + end Destroy; + + pragma Inline (Destroy); + + package Edit_Lists is new Doubly_Linked_Lists + (Element_Type => Edit_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Edit_List is Edit_Lists.Doubly_Linked_List; + type Artifact_Change is record - File : String_Ptr; - -- Name of the file + File_Index : Source_File_Index; + -- Index for the source file Replacements : Edit_List; -- Regions of texts to be edited @@ -55,9 +130,7 @@ package body Diagnostics.SARIF_Emitter is pragma Inline (Destroy); function Equals (L, R : Artifact_Change) return Boolean is - (L.File /= null - and then R.File /= null - and then L.File.all = R.File.all); + (L.File_Index = R.File_Index); package Artifact_Change_Lists is new Doubly_Linked_Lists (Element_Type => Artifact_Change, @@ -71,7 +144,7 @@ package body Diagnostics.SARIF_Emitter is -- Group edits of a Fix into Artifact_Changes that organize the edits by -- file name. - function Get_Unique_Rules (Diags : Diagnostic_List) return Diagnostic_List; + function Get_Unique_Rules return Error_Msg_List; -- Get a list of diagnostics that have unique Diagnostic Id-s. procedure Print_Replacement (Replacement : Edit_Type); @@ -90,7 +163,7 @@ package body Diagnostics.SARIF_Emitter is -- artifactChanges: [<ArtifactChange>] -- } - procedure Print_Fixes (Diag : Diagnostic_Type); + procedure Print_Fixes (E_Msg : Error_Msg_Object); -- Print the fixes node -- -- "fixes": [ @@ -119,15 +192,15 @@ package body Diagnostics.SARIF_Emitter is -- replacements: [<Replacements>] -- } - procedure Print_Artifact_Location (File_Name : String); + procedure Print_Artifact_Location (Sfile : Source_File_Index); -- Print an artifactLocation node -- -- "artifactLocation": { - -- "URI": <File_Name> + -- "uri": <File_Name>, + -- "uriBaseId": "PWD" -- } - procedure Print_Location (Loc : Labeled_Span_Type; - Msg : String_Ptr); + procedure Print_Location (Loc : Labeled_Span_Type; Msg : String_Ptr); -- Print a location node that consists of -- * an optional message node -- * a physicalLocation node @@ -140,7 +213,7 @@ package body Diagnostics.SARIF_Emitter is -- }, -- "physicalLocation": { -- "artifactLocation": { - -- "URI": <File_Name (Loc)> + -- "uri": <File_Name (Loc)> -- }, -- "region": { -- "startLine": <Line(Loc.Fst)>, @@ -151,7 +224,7 @@ package body Diagnostics.SARIF_Emitter is -- } -- } - procedure Print_Locations (Diag : Diagnostic_Type); + procedure Print_Locations (E_Msg : Error_Msg_Object); -- Print a locations node that consists of multiple location nodes. However -- typically just one location for the primary span of the diagnostic. -- @@ -159,14 +232,26 @@ package body Diagnostics.SARIF_Emitter is -- <Location (Primary_Span (Diag))> -- ], - procedure Print_Message (Text : String; Name : String := "message"); - -- Print a SARIF message node + procedure Print_Message (Text : String; Name : String := N_MESSAGE); + -- Print a SARIF message node. -- - -- "message": { + -- There are many message type nodes in the SARIF report however they can + -- have a different node <Name>. + -- + -- <Name>: { -- "text": <text> -- }, - procedure Print_Related_Locations (Diag : Diagnostic_Type); + procedure Print_Original_Uri_Base_Ids; + -- Print the originalUriBaseIds that holds the PWD value + -- + -- "originalUriBaseIds": { + -- "PWD": { + -- "uri": "<current_working_directory>" + -- } + -- }, + + procedure Print_Related_Locations (E_Msg : Error_Msg_Object); -- Print a relatedLocations node that consists of multiple location nodes. -- Related locations are the non-primary spans of the diagnostic and the -- primary locations of sub-diagnostics. @@ -175,11 +260,12 @@ package body Diagnostics.SARIF_Emitter is -- <Location (Diag.Loc)> -- ], - procedure Print_Region (Start_Line : Int; - Start_Col : Int; - End_Line : Int; - End_Col : Int; - Name : String := "region"); + procedure Print_Region + (Start_Line : Int; + Start_Col : Int; + End_Line : Int; + End_Col : Int; + Name : String := N_REGION); -- Print a region node. -- -- More specifically a text region node that specifies the textual @@ -207,7 +293,7 @@ package body Diagnostics.SARIF_Emitter is -- the GNAT span definition and we amend the endColumn value so that it -- matches the SARIF definition. - procedure Print_Result (Diag : Diagnostic_Type); + procedure Print_Result (E_Msg : Error_Msg_Object); -- { -- "ruleId": <Diag.Id>, -- "level": <Diag.Kind>, @@ -218,7 +304,7 @@ package body Diagnostics.SARIF_Emitter is -- "relatedLocations": [<Secondary_Locations>] -- }, - procedure Print_Results (Diags : Diagnostic_List); + procedure Print_Results; -- Print a results node that consists of multiple result nodes for each -- diagnostic instance. -- @@ -226,7 +312,7 @@ package body Diagnostics.SARIF_Emitter is -- <Result (Diag)> -- ] - procedure Print_Rule (Diag : Diagnostic_Type); + procedure Print_Rule (E : Error_Msg_Object); -- Print a rule node that consists of the following attributes: -- * ruleId -- * name @@ -236,7 +322,7 @@ package body Diagnostics.SARIF_Emitter is -- "name": <Human_Id(Diag)> -- }, - procedure Print_Rules (Diags : Diagnostic_List); + procedure Print_Rules; -- Print a rules node that consists of multiple rule nodes. -- Rules are considered to be a set of unique diagnostics with the unique -- id-s. @@ -245,7 +331,7 @@ package body Diagnostics.SARIF_Emitter is -- <Rule (Diag)> -- ] - procedure Print_Runs (Diags : Diagnostic_List); + procedure Print_Runs; -- Print a runs node that can consist of multiple run nodes. -- However for our report it consists of a single run that consists of -- * a tool node @@ -256,7 +342,7 @@ package body Diagnostics.SARIF_Emitter is -- "results": [<Results (Diags)>] -- } - procedure Print_Tool (Diags : Diagnostic_List); + procedure Print_Tool; -- Print a tool node that consists of -- * a driver node that consists of: -- * name @@ -275,11 +361,9 @@ package body Diagnostics.SARIF_Emitter is -- Destroy -- ------------- - procedure Destroy (Elem : in out Artifact_Change) - is - + procedure Destroy (Elem : in out Artifact_Change) is begin - Free (Elem.File); + Edit_Lists.Destroy (Elem.Replacements); end Destroy; -------------------------- @@ -294,8 +378,7 @@ package body Diagnostics.SARIF_Emitter is -- Insert -- ------------ - procedure Insert (Changes : Artifact_Change_List; E : Edit_Type) - is + procedure Insert (Changes : Artifact_Change_List; E : Edit_Type) is A : Artifact_Change; It : Artifact_Change_Lists.Iterator := @@ -304,7 +387,7 @@ package body Diagnostics.SARIF_Emitter is while Artifact_Change_Lists.Has_Next (It) loop Artifact_Change_Lists.Next (It, A); - if A.File.all = To_File_Name (E.Span.Ptr) then + if A.File_Index = Get_Source_File_Index (E.Span.Ptr) then Edit_Lists.Append (A.Replacements, E); return; end if; @@ -316,7 +399,7 @@ package body Diagnostics.SARIF_Emitter is Edit_Lists.Append (Replacements, E); Artifact_Change_Lists.Append (Changes, - (File => new String'(To_File_Name (E.Span.Ptr)), + (File_Index => Get_Source_File_Index (E.Span.Ptr), Replacements => Replacements)); end; end Insert; @@ -325,12 +408,19 @@ package body Diagnostics.SARIF_Emitter is E : Edit_Type; - It : Edit_Lists.Iterator := Edit_Lists.Iterate (Fix.Edits); + It : Edit_Id; + + -- Start of processing for Get_Artifact_Changes + begin - while Edit_Lists.Has_Next (It) loop - Edit_Lists.Next (It, E); + It := Fix.Edits; + + while It /= No_Edit loop + E := Edits.Table (It); Insert (Changes, E); + + It := E.Next; end loop; return Changes; @@ -340,46 +430,46 @@ package body Diagnostics.SARIF_Emitter is -- Get_Unique_Rules -- ---------------------- - function Get_Unique_Rules (Diags : Diagnostic_List) - return Diagnostic_List - is - use Diagnostics.Diagnostics_Lists; + function Get_Unique_Rules return Error_Msg_List is + use Error_Msg_Lists; - procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type); + procedure Insert (Rules : Error_Msg_List; E : Error_Msg_Object); ------------ -- Insert -- ------------ - procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type) is + procedure Insert (Rules : Error_Msg_List; E : Error_Msg_Object) is It : Iterator := Iterate (Rules); - R : Diagnostic_Type; + R : Error_Msg_Object; begin while Has_Next (It) loop Next (It, R); - if R.Id = D.Id then + if R.Id = E.Id then return; - elsif R.Id > D.Id then - Insert_Before (Rules, R, D); + elsif R.Id > E.Id then + Insert_Before (Rules, R, E); return; end if; end loop; - Append (Rules, D); + Append (Rules, E); end Insert; - D : Diagnostic_Type; - Unique_Rules : constant Diagnostic_List := Create; + Unique_Rules : constant Error_Msg_List := Create; + + E : Error_Msg_Id; + + -- Start of processing for Get_Unique_Rules - It : Iterator := Iterate (Diags); begin - if Present (Diags) then - while Has_Next (It) loop - Next (It, D); - Insert (Unique_Rules, D); - end loop; - end if; + E := First_Error_Msg; + while E /= No_Error_Msg loop + Insert (Unique_Rules, Errors.Table (E)); + + Next_Error_Msg (E); + end loop; return Unique_Rules; end Get_Unique_Rules; @@ -388,10 +478,9 @@ package body Diagnostics.SARIF_Emitter is -- Print_Artifact_Change -- --------------------------- - procedure Print_Artifact_Change (A : Artifact_Change) - is - use Diagnostics.Edit_Lists; - E : Edit_Type; + procedure Print_Artifact_Change (A : Artifact_Change) is + use Edit_Lists; + E : Edit_Type; E_It : Iterator; First : Boolean := True; @@ -402,12 +491,12 @@ package body Diagnostics.SARIF_Emitter is -- Print artifactLocation - Print_Artifact_Location (A.File.all); + Print_Artifact_Location (A.File_Index); Write_Char (','); NL_And_Indent; - Write_Str ("""" & "replacements" & """" & ": " & "["); + Write_Str ("""" & N_REPLACEMENTS & """" & ": " & "["); Begin_Block; NL_And_Indent; @@ -443,14 +532,49 @@ package body Diagnostics.SARIF_Emitter is -- Print_Artifact_Location -- ----------------------------- - procedure Print_Artifact_Location (File_Name : String) is - + procedure Print_Artifact_Location (Sfile : Source_File_Index) is + Full_Name : constant String := Get_Name_String (Full_Ref_Name (Sfile)); begin - Write_Str ("""" & "artifactLocation" & """" & ": " & "{"); + Write_Str ("""" & N_ARTIFACT_LOCATION & """" & ": " & "{"); Begin_Block; NL_And_Indent; - Write_String_Attribute ("uri", File_Name); + if System.OS_Lib.Is_Absolute_Path (Full_Name) then + declare + Abs_Name : constant String := + System.OS_Lib.Normalize_Pathname + (Name => Full_Name, Resolve_Links => False); + begin + -- We cannot create relative paths between different drives on + -- Windows. If the path is on a different drive than the PWD print + -- the absolute path in the URI and omit the baseUriId attribute. + + if Osint.On_Windows + and then Abs_Name (Abs_Name'First) = + Current_Dir (Current_Dir'First) + then + Write_String_Attribute (N_URI, To_File_Uri (Abs_Name)); + else + Write_String_Attribute + (N_URI, To_File_Uri (Relative_Path (Abs_Name, Current_Dir))); + + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name); + end if; + end; + else + -- If the path was not absolute it was given relative to the + -- uriBaseId. + + Write_String_Attribute (N_URI, To_File_Uri (Full_Name)); + + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name); + end if; End_Block; NL_And_Indent; @@ -478,17 +602,18 @@ package body Diagnostics.SARIF_Emitter is -- Print deletedRegion - Print_Region (Start_Line => Line_Fst, - Start_Col => Col_Fst, - End_Line => Line_Lst, - End_Col => Col_Lst, - Name => "deletedRegion"); + Print_Region + (Start_Line => Line_Fst, + Start_Col => Col_Fst, + End_Line => Line_Lst, + End_Col => Col_Lst, + Name => N_DELETED_REGION); if Replacement.Text /= null then Write_Char (','); NL_And_Indent; - Print_Message (Replacement.Text.all, "insertedContent"); + Print_Message (Replacement.Text.all, N_INSERTED_CONTENT); end if; -- End replacement @@ -512,7 +637,7 @@ package body Diagnostics.SARIF_Emitter is -- Print the message if the location has one if Fix.Description /= null then - Print_Message (Fix.Description.all, "description"); + Print_Message (Fix.Description.all, N_DESCRIPTION); Write_Char (','); NL_And_Indent; @@ -522,9 +647,9 @@ package body Diagnostics.SARIF_Emitter is use Artifact_Change_Lists; Changes : Artifact_Change_List := Get_Artifact_Changes (Fix); A : Artifact_Change; - A_It : Iterator := Iterate (Changes); + A_It : Iterator := Iterate (Changes); begin - Write_Str ("""" & "artifactChanges" & """" & ": " & "["); + Write_Str ("""" & N_ARTIFACT_CHANGES & """" & ": " & "["); Begin_Block; while Has_Next (A_It) loop @@ -557,31 +682,30 @@ package body Diagnostics.SARIF_Emitter is -- Print_Fixes -- ----------------- - procedure Print_Fixes (Diag : Diagnostic_Type) is - use Diagnostics.Fix_Lists; - F : Fix_Type; - F_It : Iterator; + procedure Print_Fixes (E_Msg : Error_Msg_Object) is + F : Fix_Type; + F_It : Fix_Id; First : Boolean := True; begin - Write_Str ("""" & "fixes" & """" & ": " & "["); + Write_Str ("""" & N_FIXES & """" & ": " & "["); Begin_Block; - if Present (Diag.Fixes) then - F_It := Iterate (Diag.Fixes); - while Has_Next (F_It) loop - Next (F_It, F); + F_It := E_Msg.Fixes; + while F_It /= No_Fix loop + F := Fixes.Table (F_It); - if First then - First := False; - else - Write_Char (','); - end if; + if First then + First := False; + else + Write_Char (','); + end if; - NL_And_Indent; - Print_Fix (F); - end loop; - end if; + NL_And_Indent; + Print_Fix (F); + + F_It := F.Next; + end loop; End_Block; NL_And_Indent; @@ -601,6 +725,9 @@ package body Diagnostics.SARIF_Emitter is function Compose_Command_Line return String is Buffer : Bounded_String; begin + Find_Program_Name; + Append (Buffer, Name_Buffer (1 .. Name_Len)); + Append (Buffer, ' '); Append (Buffer, Get_First_Main_File_Name); for I in 1 .. Compilation_Switches_Last loop declare @@ -616,7 +743,7 @@ package body Diagnostics.SARIF_Emitter is end Compose_Command_Line; begin - Write_Str ("""" & "invocations" & """" & ": " & "["); + Write_Str ("""" & N_INVOCATIONS & """" & ": " & "["); Begin_Block; NL_And_Indent; @@ -626,13 +753,13 @@ package body Diagnostics.SARIF_Emitter is -- Print commandLine - Write_String_Attribute ("commandLine", Compose_Command_Line); + Write_String_Attribute (N_COMMAND_LINE, Compose_Command_Line); Write_Char (','); NL_And_Indent; -- Print executionSuccessful - Write_Boolean_Attribute ("executionSuccessful", Compilation_Errors); + Write_Boolean_Attribute (N_EXECUTION_SUCCESSFUL, not Compilation_Errors); End_Block; NL_And_Indent; @@ -647,11 +774,12 @@ package body Diagnostics.SARIF_Emitter is -- Print_Region -- ------------------ - procedure Print_Region (Start_Line : Int; - Start_Col : Int; - End_Line : Int; - End_Col : Int; - Name : String := "region") + procedure Print_Region + (Start_Line : Int; + Start_Col : Int; + End_Line : Int; + End_Col : Int; + Name : String := N_REGION) is begin @@ -659,22 +787,22 @@ package body Diagnostics.SARIF_Emitter is Begin_Block; NL_And_Indent; - Write_Int_Attribute ("startLine", Start_Line); + Write_Int_Attribute (N_START_LINE, Start_Line); Write_Char (','); NL_And_Indent; - Write_Int_Attribute ("startColumn", Start_Col); + Write_Int_Attribute (N_START_COLUMN, Start_Col); Write_Char (','); NL_And_Indent; - Write_Int_Attribute ("endLine", End_Line); + Write_Int_Attribute (N_END_LINE, End_Line); Write_Char (','); NL_And_Indent; -- Convert the end of the span to the definition of the endColumn -- for a SARIF region. - Write_Int_Attribute ("endColumn", End_Col + 1); + Write_Int_Attribute (N_END_COLUMN, End_Col + 1); End_Block; NL_And_Indent; @@ -685,9 +813,7 @@ package body Diagnostics.SARIF_Emitter is -- Print_Location -- -------------------- - procedure Print_Location (Loc : Labeled_Span_Type; - Msg : String_Ptr) - is + procedure Print_Location (Loc : Labeled_Span_Type; Msg : String_Ptr) is -- Span start positions Fst : constant Source_Ptr := Loc.Span.First; @@ -713,23 +839,24 @@ package body Diagnostics.SARIF_Emitter is NL_And_Indent; end if; - Write_Str ("""" & "physicalLocation" & """" & ": " & "{"); + Write_Str ("""" & N_PHYSICAL_LOCATION & """" & ": " & "{"); Begin_Block; NL_And_Indent; -- Print artifactLocation - Print_Artifact_Location (To_File_Name (Loc.Span.Ptr)); + Print_Artifact_Location (Get_Source_File_Index (Loc.Span.Ptr)); Write_Char (','); NL_And_Indent; -- Print region - Print_Region (Start_Line => Line_Fst, - Start_Col => Col_Fst, - End_Line => Line_Lst, - End_Col => Col_Lst); + Print_Region + (Start_Line => Line_Fst, + Start_Col => Col_Fst, + End_Line => Line_Lst, + End_Col => Col_Lst); End_Block; NL_And_Indent; @@ -744,18 +871,18 @@ package body Diagnostics.SARIF_Emitter is -- Print_Locations -- --------------------- - procedure Print_Locations (Diag : Diagnostic_Type) is - use Diagnostics.Labeled_Span_Lists; + procedure Print_Locations (E_Msg : Error_Msg_Object) is Loc : Labeled_Span_Type; - It : Iterator := Iterate (Diag.Locations); + It : Labeled_Span_Id; First : Boolean := True; begin - Write_Str ("""" & "locations" & """" & ": " & "["); + Write_Str ("""" & N_LOCATIONS & """" & ": " & "["); Begin_Block; - while Has_Next (It) loop - Next (It, Loc); + It := E_Msg.Locations; + while It /= No_Labeled_Span loop + Loc := Locations.Table (It); -- Only the primary span is considered as the main location other -- spans are considered related locations @@ -770,51 +897,77 @@ package body Diagnostics.SARIF_Emitter is NL_And_Indent; Print_Location (Loc, Loc.Label); end if; + + It := Loc.Next; end loop; End_Block; NL_And_Indent; Write_Char (']'); - end Print_Locations; ------------------- -- Print_Message -- ------------------- - procedure Print_Message (Text : String; Name : String := "message") is + procedure Print_Message (Text : String; Name : String := N_MESSAGE) is begin Write_Str ("""" & Name & """" & ": " & "{"); Begin_Block; NL_And_Indent; - Write_String_Attribute ("text", Text); + Write_String_Attribute (N_TEXT, Text); End_Block; NL_And_Indent; Write_Char ('}'); end Print_Message; + --------------------------------- + -- Print_Original_Uri_Base_Ids -- + --------------------------------- + + procedure Print_Original_Uri_Base_Ids is + begin + Write_Str ("""" & N_ORIGINAL_URI_BASE_IDS & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_Str ("""" & URI_Base_Id_Name & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute (N_URI, To_File_Uri (Current_Dir)); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Original_Uri_Base_Ids; + ----------------------------- -- Print_Related_Locations -- ----------------------------- - procedure Print_Related_Locations (Diag : Diagnostic_Type) is - Loc : Labeled_Span_Type; - Loc_It : Labeled_Span_Lists.Iterator := - Labeled_Span_Lists.Iterate (Diag.Locations); + procedure Print_Related_Locations (E_Msg : Error_Msg_Object) is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Id; - Sub : Sub_Diagnostic_Type; - Sub_It : Sub_Diagnostic_Lists.Iterator; + Sub : Error_Msg_Object; + Sub_It : Error_Msg_Id; First : Boolean := True; begin - Write_Str ("""" & "relatedLocations" & """" & ": " & "["); + Write_Str ("""" & N_RELATED_LOCATIONS & """" & ": " & "["); Begin_Block; -- Related locations are the non-primary spans of the diagnostic - while Labeled_Span_Lists.Has_Next (Loc_It) loop - Labeled_Span_Lists.Next (Loc_It, Loc); + Loc_It := E_Msg.Locations; + while Loc_It /= No_Labeled_Span loop + Loc := Locations.Table (Loc_It); -- Non-primary spans are considered related locations @@ -828,78 +981,64 @@ package body Diagnostics.SARIF_Emitter is NL_And_Indent; Print_Location (Loc, Loc.Label); end if; + Loc_It := Loc.Next; end loop; -- And the sub-diagnostic locations - if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then - Sub_It := Sub_Diagnostic_Lists.Iterate (Diag.Sub_Diagnostics); + Sub_It := E_Msg.Next; + while Sub_It /= No_Error_Msg and then Errors.Table (Sub_It).Msg_Cont loop + Sub := Errors.Table (Sub_It); - while Sub_Diagnostic_Lists.Has_Next (Sub_It) loop - Sub_Diagnostic_Lists.Next (Sub_It, Sub); - - declare - Found : Boolean := False; + declare + Found : Boolean := False; - Prim_Loc : Labeled_Span_Type; - begin - if Labeled_Span_Lists.Present (Sub.Locations) then - Loc_It := Labeled_Span_Lists.Iterate (Sub.Locations); - while Labeled_Span_Lists.Has_Next (Loc_It) loop - Labeled_Span_Lists.Next (Loc_It, Loc); - - -- For sub-diagnostic locations, only the primary span is - -- considered. - - if not Found and then Loc.Is_Primary then - Found := True; - Prim_Loc := Loc; - end if; - end loop; - else + Prim_Loc_Id : Labeled_Span_Id; + begin + Prim_Loc_Id := Primary_Location (Sub); - -- If there are no locations for the sub-diagnostic then use - -- the primary location of the main diagnostic. + if Prim_Loc_Id /= No_Labeled_Span then + Found := True; + else + Prim_Loc_Id := Primary_Location (E_Msg); + Found := True; + end if; - Found := True; - Prim_Loc := Primary_Location (Diag); + -- For mapping sub-diagnostics to related locations we have to + -- make some compromises in details. + -- + -- Firstly we only make one entry that is for the primary span + -- of the sub-diagnostic. + -- + -- Secondly this span can also have a label. However this + -- pattern is not advised and by default we include the message + -- of the sub-diagnostic as the message in location node since + -- it should have more information. + + if Found then + if First then + First := False; + else + Write_Char (','); end if; + NL_And_Indent; + Print_Location (Locations.Table (Prim_Loc_Id), Sub.Text); + end if; + end; - -- For mapping sub-diagnostics to related locations we have to - -- make some compromises in details. - -- - -- Firstly we only make one entry that is for the primary span - -- of the sub-diagnostic. - -- - -- Secondly this span can also have a label. However this - -- pattern is not advised and by default we include the message - -- of the sub-diagnostic as the message in location node since - -- it should have more information. - - if Found then - if First then - First := False; - else - Write_Char (','); - end if; - NL_And_Indent; - Print_Location (Prim_Loc, Sub.Message); - end if; - end; - end loop; - end if; + Next_Continuation_Msg (Sub_It); + end loop; End_Block; NL_And_Indent; Write_Char (']'); - end Print_Related_Locations; ------------------ -- Print_Result -- ------------------ - procedure Print_Result (Diag : Diagnostic_Type) is + procedure Print_Result (E_Msg : Error_Msg_Object) is begin Write_Char ('{'); @@ -908,42 +1047,42 @@ package body Diagnostics.SARIF_Emitter is -- Print ruleId - Write_String_Attribute ("ruleId", "[" & To_String (Diag.Id) & "]"); + Write_String_Attribute (N_RULE_ID, "[" & To_String (E_Msg.Id) & "]"); Write_Char (','); NL_And_Indent; -- Print level - Write_String_Attribute ("level", Kind_To_String (Diag)); + Write_String_Attribute (N_LEVEL, Kind_To_String (E_Msg)); Write_Char (','); NL_And_Indent; -- Print message - Print_Message (Diag.Message.all); + Print_Message (E_Msg.Text.all); Write_Char (','); NL_And_Indent; -- Print locations - Print_Locations (Diag); + Print_Locations (E_Msg); Write_Char (','); NL_And_Indent; -- Print related locations - Print_Related_Locations (Diag); + Print_Related_Locations (E_Msg); Write_Char (','); NL_And_Indent; -- Print fixes - Print_Fixes (Diag); + Print_Fixes (E_Msg); End_Block; NL_And_Indent; @@ -955,32 +1094,28 @@ package body Diagnostics.SARIF_Emitter is -- Print_Results -- ------------------- - procedure Print_Results (Diags : Diagnostic_List) is - use Diagnostics.Diagnostics_Lists; - - D : Diagnostic_Type; - - It : Iterator := Iterate (All_Diagnostics); + procedure Print_Results is + E : Error_Msg_Id; First : Boolean := True; begin - Write_Str ("""" & "results" & """" & ": " & "["); + Write_Str ("""" & N_RESULTS & """" & ": " & "["); Begin_Block; - if Present (Diags) then - while Has_Next (It) loop - Next (It, D); + E := First_Error_Msg; + while E /= No_Error_Msg loop + if First then + First := False; + else + Write_Char (','); + end if; - if First then - First := False; - else - Write_Char (','); - end if; + NL_And_Indent; - NL_And_Indent; - Print_Result (D); - end loop; - end if; + Print_Result (Errors.Table (E)); + + Next_Error_Msg (E); + end loop; End_Block; NL_And_Indent; @@ -991,21 +1126,21 @@ package body Diagnostics.SARIF_Emitter is -- Print_Rule -- ---------------- - procedure Print_Rule (Diag : Diagnostic_Type) is - Human_Id : constant String_Ptr := Get_Human_Id (Diag); + procedure Print_Rule (E : Error_Msg_Object) is + Human_Id : constant String_Ptr := Get_Human_Id (E); begin Write_Char ('{'); Begin_Block; NL_And_Indent; - Write_String_Attribute ("id", "[" & To_String (Diag.Id) & "]"); + Write_String_Attribute (N_ID, "[" & To_String (E.Id) & "]"); Write_Char (','); NL_And_Indent; if Human_Id = null then - Write_String_Attribute ("name", "Uncategorized_Diagnostic"); + Write_String_Attribute (N_NAME, "Uncategorized_Diagnostic"); else - Write_String_Attribute ("name", Human_Id.all); + Write_String_Attribute (N_NAME, Human_Id.all); end if; End_Block; @@ -1017,17 +1152,15 @@ package body Diagnostics.SARIF_Emitter is -- Print_Rules -- ----------------- - procedure Print_Rules (Diags : Diagnostic_List) is - use Diagnostics.Diagnostics_Lists; - - R : Diagnostic_Type; - Rules : constant Diagnostic_List := Get_Unique_Rules (Diags); - - It : Iterator := Iterate (Rules); + procedure Print_Rules is + use Error_Msg_Lists; + R : Error_Msg_Object; + Rules : Error_Msg_List := Get_Unique_Rules; + It : Iterator := Iterate (Rules); First : Boolean := True; begin - Write_Str ("""" & "rules" & """" & ": " & "["); + Write_Str ("""" & N_RULES & """" & ": " & "["); Begin_Block; while Has_Next (It) loop @@ -1047,36 +1180,37 @@ package body Diagnostics.SARIF_Emitter is NL_And_Indent; Write_Char (']'); + Error_Msg_Lists.Destroy (Rules); end Print_Rules; ---------------- -- Print_Tool -- ---------------- - procedure Print_Tool (Diags : Diagnostic_List) is + procedure Print_Tool is begin - Write_Str ("""" & "tool" & """" & ": " & "{"); + Write_Str ("""" & N_TOOL & """" & ": " & "{"); Begin_Block; NL_And_Indent; -- -- Attributes of tool - Write_Str ("""" & "driver" & """" & ": " & "{"); + Write_Str ("""" & N_DRIVER & """" & ": " & "{"); Begin_Block; NL_And_Indent; -- Attributes of tool.driver - Write_String_Attribute ("name", "GNAT"); + Write_String_Attribute (N_NAME, "GNAT"); Write_Char (','); NL_And_Indent; - Write_String_Attribute ("version", Gnat_Version_String); + Write_String_Attribute (N_VERSION, Gnat_Version_String); Write_Char (','); NL_And_Indent; - Print_Rules (Diags); + Print_Rules; -- End of tool.driver @@ -1097,10 +1231,10 @@ package body Diagnostics.SARIF_Emitter is -- Print_Runs -- ---------------- - procedure Print_Runs (Diags : Diagnostic_List) is + procedure Print_Runs is begin - Write_Str ("""" & "runs" & """" & ": " & "["); + Write_Str ("""" & N_RUNS & """" & ": " & "["); Begin_Block; NL_And_Indent; @@ -1113,7 +1247,7 @@ package body Diagnostics.SARIF_Emitter is -- A run consists of a tool - Print_Tool (Diags); + Print_Tool; Write_Char (','); NL_And_Indent; @@ -1124,9 +1258,13 @@ package body Diagnostics.SARIF_Emitter is Write_Char (','); NL_And_Indent; + Print_Original_Uri_Base_Ids; + Write_Char (','); + NL_And_Indent; + -- A run consists of results - Print_Results (Diags); + Print_Results; -- End of run @@ -1147,21 +1285,21 @@ package body Diagnostics.SARIF_Emitter is -- Print_SARIF_Report -- ------------------------ - procedure Print_SARIF_Report (Diags : Diagnostic_List) is + procedure Print_SARIF_Report is begin Write_Char ('{'); Begin_Block; NL_And_Indent; - Write_String_Attribute ("$schema", SARIF_Schema); + Write_String_Attribute (N_SCHEMA, SARIF_Schema); Write_Char (','); NL_And_Indent; - Write_String_Attribute ("version", SARIF_Version); + Write_String_Attribute (N_VERSION, SARIF_Version); Write_Char (','); NL_And_Indent; - Print_Runs (Diags); + Print_Runs; End_Block; NL_And_Indent; @@ -1170,4 +1308,4 @@ package body Diagnostics.SARIF_Emitter is Write_Eol; end Print_SARIF_Report; -end Diagnostics.SARIF_Emitter; +end Erroutc.SARIF_Emitter; diff --git a/gcc/ada/diagnostics-sarif_emitter.ads b/gcc/ada/erroutc-sarif_emitter.ads index 4c8ec78..9272b54 100644 --- a/gcc/ada/diagnostics-sarif_emitter.ads +++ b/gcc/ada/erroutc-sarif_emitter.ads @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ -package Diagnostics.SARIF_Emitter is +package Erroutc.SARIF_Emitter is - procedure Print_SARIF_Report (Diags : Diagnostic_List); -end Diagnostics.SARIF_Emitter; + procedure Print_SARIF_Report; +end Erroutc.SARIF_Emitter; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index c8de60d..76113b9 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -491,6 +491,134 @@ package body Erroutc is E_Msg.Kind in Warning | Info | Style and then E_Msg.Warn_Chr /= " "; end Has_Switch_Tag; + -------------------- + -- Next_Error_Msg -- + -------------------- + + procedure Next_Error_Msg (E : in out Error_Msg_Id) is + begin + loop + E := Errors.Table (E).Next; + exit when E = No_Error_Msg; + exit when not Errors.Table (E).Deleted + and then not Errors.Table (E).Msg_Cont; + end loop; + end Next_Error_Msg; + + --------------------------- + -- Next_Continuation_Msg -- + --------------------------- + + procedure Next_Continuation_Msg (E : in out Error_Msg_Id) is + begin + E := Errors.Table (E).Next; + + if E = No_Error_Msg or else not Errors.Table (E).Msg_Cont then + E := No_Error_Msg; + end if; + end Next_Continuation_Msg; + + ---------------------- + -- Primary_Location -- + ---------------------- + + function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id is + L : Labeled_Span_Id; + begin + L := E.Locations; + while L /= No_Labeled_Span loop + if Locations.Table (L).Is_Primary then + return L; + end if; + + L := Locations.Table (L).Next; + end loop; + + return No_Labeled_Span; + end Primary_Location; + + ------------------ + -- Get_Human_Id -- + ------------------ + + function Get_Human_Id (E : Error_Msg_Object) return String_Ptr is + begin + if E.Switch = No_Switch_Id then + return Diagnostic_Entries (E.Id).Human_Id; + else + return Get_Switch (E).Human_Id; + end if; + end Get_Human_Id; + + -------------------- + -- Get_Doc_Switch -- + -------------------- + + function Get_Doc_Switch (E : Error_Msg_Object) return String is + begin + if Warning_Doc_Switch + and then E.Warn_Chr /= " " + and then E.Kind in Info + | Style + | Warning + then + if E.Switch = No_Switch_Id then + if E.Warn_Chr = "* " then + return "[restriction warning]"; + + -- Info messages can have a switch tag but they should not have + -- a default switch tag. + + elsif E.Kind /= Info then + + -- For Default_Warning + + return "[enabled by default]"; + end if; + else + declare + S : constant Switch_Type := Get_Switch (E); + begin + return "[-" & S.Short_Name.all & "]"; + end; + end if; + end if; + + return ""; + end Get_Doc_Switch; + + ---------------- + -- Get_Switch -- + ---------------- + + function Get_Switch (E : Error_Msg_Object) return Switch_Type is + begin + return Get_Switch (E.Switch); + end Get_Switch; + + ------------------- + -- Get_Switch_Id -- + ------------------- + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is + begin + return Get_Switch_Id (E.Kind, E.Warn_Chr); + end Get_Switch_Id; + + function Get_Switch_Id + (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id is + begin + if Warn_Chr = "$ " then + return Get_Switch_Id ("gnatel"); + elsif Kind in Warning | Info then + return Get_Switch_Id ("gnatw" & Warn_Chr); + elsif Kind = Style then + return Get_Switch_Id ("gnaty" & Warn_Chr); + else + return No_Switch_Id; + end if; + end Get_Switch_Id; + ------------- -- Matches -- ------------- @@ -752,7 +880,7 @@ package body Erroutc is -- Output_Text_Within -- ------------------------ - procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat) is + procedure Output_Text_Within (Txt : String; Line_Length : Nat) is Offs : constant Nat := Column - 1; -- Offset to start of message, used for continuations @@ -869,98 +997,62 @@ package body Erroutc is procedure Output_Msg_Text (E : Error_Msg_Id) is - E_Msg : Error_Msg_Object renames Errors.Table (E); - Text : constant String_Ptr := E_Msg.Text; - Tag : constant String := Get_Warning_Tag (E); - Txt : String_Ptr; - - Line_Length : constant Nat := + E_Msg : Error_Msg_Object renames Errors.Table (E); + Text : constant String_Ptr := E_Msg.Text; + Tag : constant String := Get_Warning_Tag (E); + SGR_Code : constant String := Get_SGR_Code (E_Msg); + Kind_Prefix : constant String := + (if E_Msg.Kind = Style then Style_Prefix + else Kind_To_String (E_Msg) & ": "); + Buf : Bounded_String (Max_Msg_Length); + Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last else Error_Msg_Line_Length); begin - -- Postfix warning tag to message if needed - - if Tag /= "" and then Warning_Doc_Switch then - Txt := new String'(Text.all & ' ' & Tag); - else - Txt := Text; - end if; - - -- If -gnatdF is used, continuation messages follow the main message - -- with only an indentation of two space characters, without repeating - -- any prefix. - - if Debug_Flag_FF and then E_Msg.Msg_Cont then - null; - - -- For info messages, prefix message with "info: " - - elsif E_Msg.Kind = Info then - Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all); + -- Prefix with "error:" rather than warning. + -- Additionally include the style suffix when needed. - -- Warning treated as error - - elsif E_Msg.Warn_Err then - - -- We prefix with "error:" rather than warning: and postfix - -- [warning-as-error] at the end. + if E_Msg.Warn_Err then Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; - Txt := new String'(SGR_Error & "error: " & SGR_Reset - & Txt.all & " [warning-as-error]"); - - -- Normal warning, prefix with "warning: " - - elsif E_Msg.Kind = Warning then - Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all); - - -- No prefix needed for style message, "(style)" is there already - - elsif E_Msg.Kind = Style then - if Txt (Txt'First .. Txt'First + 6) = "(style)" then - Txt := new String'(SGR_Warning & "(style)" & SGR_Reset - & Txt (Txt'First + 7 .. Txt'Last)); - end if; - - -- No prefix needed for check message, severity is there already - - elsif E_Msg.Kind in High_Check | Medium_Check | Low_Check then - -- The message format is "severity: ..." - -- - -- Enclose the severity with an SGR control string if requested - - if Use_SGR_Control then - declare - Msg : String renames Text.all; - Colon : Natural := 0; - begin - -- Find first colon + Append + (Buf, + SGR_Error & "error: " & SGR_Reset & + (if E_Msg.Kind = Style then Style_Prefix else "")); + + -- Print the message kind prefix + -- * Info/Style/Warning messages + -- * Check messages that are not continuations in the pretty printer + -- * Error messages when error tags are allowed + + elsif E_Msg.Kind in Info | Style | Warning + or else + (E_Msg.Kind in High_Check | Medium_Check | Low_Check + and then not (E_Msg.Msg_Cont and then Debug_Flag_FF)) + or else + (E_Msg.Kind in Error | Non_Serious_Error + and then Opt.Unique_Error_Tag) + then + Append (Buf, SGR_Code & Kind_Prefix & SGR_Reset); + end if; - for J in Msg'Range loop - if Msg (J) = ':' then - Colon := J; - exit; - end if; - end loop; + Append (Buf, Text.all); - pragma Assert (Colon > 0); + -- Postfix warning tag to message if needed - Txt := new String'(SGR_Error - & Msg (Msg'First .. Colon) - & SGR_Reset - & Msg (Colon + 1 .. Msg'Last)); - end; - end if; + if Tag /= "" and then Warning_Doc_Switch then + Append (Buf, ' ' & Tag); + end if; - -- All other cases, add "error: " if unique error tag set + -- Postfix [warning-as-error] at the end - elsif Opt.Unique_Error_Tag then - Txt := new String'(SGR_Error & "error: " & SGR_Reset & Txt.all); + if E_Msg.Warn_Err then + Append (Buf, " [warning-as-error]"); end if; - Output_Text_Within (Txt, Line_Length); + Output_Text_Within (To_String (Buf), Line_Length); end Output_Msg_Text; --------------------- @@ -1056,36 +1148,46 @@ package body Erroutc is -- Check style message - if Msg'Length > 7 - and then Msg (Msg'First .. Msg'First + 6) = "(style)" + if Msg'Length > Style_Prefix'Length + and then + Msg (Msg'First .. Msg'First + Style_Prefix'Length - 1) = + Style_Prefix then Error_Msg_Kind := Style; -- Check info message - elsif Msg'Length > 6 - and then Msg (Msg'First .. Msg'First + 5) = "info: " + elsif Msg'Length > Info_Prefix'Length + and then + Msg (Msg'First .. Msg'First + Info_Prefix'Length - 1) = + Info_Prefix then Error_Msg_Kind := Info; -- Check high check message - elsif Msg'Length > 6 - and then Msg (Msg'First .. Msg'First + 5) = "high: " + elsif Msg'Length > High_Prefix'Length + and then + Msg (Msg'First .. Msg'First + High_Prefix'Length - 1) = + High_Prefix then Error_Msg_Kind := High_Check; -- Check medium check message - elsif Msg'Length > 8 - and then Msg (Msg'First .. Msg'First + 7) = "medium: " + elsif Msg'Length > Medium_Prefix'Length + and then + Msg (Msg'First .. Msg'First + Medium_Prefix'Length - 1) = + Medium_Prefix then Error_Msg_Kind := Medium_Check; -- Check low check message - elsif Msg'Length > 5 - and then Msg (Msg'First .. Msg'First + 4) = "low: " + elsif Msg'Length > Low_Prefix'Length + and then + Msg (Msg'First .. Msg'First + Low_Prefix'Length - 1) = + Low_Prefix then Error_Msg_Kind := Low_Check; end if; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 3f080a5..5ee2679 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -27,6 +27,8 @@ -- reporting packages, including Errout and Prj.Err. with Table; +with Errsw; use Errsw; +with Errid; use Errid; with Types; use Types; package Erroutc is @@ -177,6 +179,84 @@ package Erroutc is -- The following record type and table are used to represent error -- messages, with one entry in the table being allocated for each message. + type Labeled_Span_Id is new Int; + No_Labeled_Span : constant Labeled_Span_Id := 0; + + type Labeled_Span_Type is record + Label : String_Ptr := null; + -- Text associated with the span + + Span : Source_Span := (others => No_Location); + -- Textual region in the source code + + Is_Primary : Boolean := True; + -- Primary spans are used to indicate the primary location of the + -- diagnostic. Typically there should just be one primary span per + -- diagnostic. + -- Non-primary spans are used to indicate secondary locations and + -- typically are formatted in a different way or omitted in some + -- contexts. + + Is_Region : Boolean := False; + -- Regional spans are multiline spans that have a unique way of being + -- displayed in the pretty output. + + Next : Labeled_Span_Id := No_Labeled_Span; + + end record; + + No_Labeled_Span_Object : Labeled_Span_Type := (others => <>); + + package Locations is new Table.Table ( + Table_Component_Type => Labeled_Span_Type, + Table_Index_Type => Labeled_Span_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Location"); + + type Edit_Id is new Int; + No_Edit : constant Edit_Id := 0; + + type Edit_Type is record + Span : Source_Span; + -- Region of the file to be removed + + Text : String_Ptr; + -- Text to be inserted at the start location of the span + + Next : Edit_Id := No_Edit; + end record; + + package Edits is new Table.Table ( + Table_Component_Type => Edit_Type, + Table_Index_Type => Edit_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Edit"); + + type Fix_Id is new Int; + No_Fix : constant Fix_Id := 0; + + type Fix_Type is record + Description : String_Ptr := null; + -- Message describing the fix that will be displayed to the user. + + Edits : Edit_Id := No_Edit; + -- File changes for the fix. + + Next : Fix_Id := No_Fix; + end record; + + package Fixes is new Table.Table ( + Table_Component_Type => Fix_Type, + Table_Index_Type => Fix_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Fix"); + type Error_Msg_Object is record Text : String_Ptr; -- Text of error message, fully expanded with all insertions @@ -248,6 +328,27 @@ package Erroutc is -- in the circuit for deleting duplicate/redundant error messages. Kind : Error_Msg_Type; + -- The kind of the error message. This determines how the message + -- should be handled and what kind of prefix should be added before the + -- message text. + + Switch : Switch_Id := No_Switch_Id; + -- Identifier for a given switch that enabled the diagnostic + + Id : Diagnostic_Id := No_Diagnostic_Id; + -- Unique error code for the given message + + Locations : Labeled_Span_Id := No_Labeled_Span; + -- Identifier to the first location identified by the error message. + -- These locations are marked with an underlying span line and + -- optionally given a short label. + + Fixes : Fix_Id := No_Fix; + -- Identifier to the first fix object for the error message. The fix + -- contains a suggestion to prevent the error from being triggered. + -- This includes edits that can be made to the source code. An edit + -- contians a region of the code that needs to be changed and the new + -- text that should be inserted to that region. end record; package Errors is new Table.Table ( @@ -268,6 +369,56 @@ package Erroutc is -- as the physically last entry in the error message table, since messages -- are not always inserted in sequence. + procedure Next_Error_Msg (E : in out Error_Msg_Id); + -- Update E to point to the next error message in the list of error + -- messages. Skip deleted and continuation messages. + + procedure Next_Continuation_Msg (E : in out Error_Msg_Id); + -- Update E to point to the next continuation message + + function Kind_To_String (E : Error_Msg_Object) return String is + (if E.Warn_Err then "error" + else + (case E.Kind is + when Error | Non_Serious_Error => "error", + when Warning => "warning", + when Style => "style", + when Info => "info", + when Low_Check => "low", + when Medium_Check => "medium", + when High_Check => "high")); + -- Returns the name of the error message kind. If it is a warning that has + -- been turned to an error then it returns "error". + + function Get_Doc_Switch (E : Error_Msg_Object) return String; + -- Returns the documentation switch for a given Error_Msg_Object. + -- + -- This either the name of the switch encased in brackets. E.g [-gnatwx]. + -- + -- If the Warn_Char is "* " is then it will return [restriction warning]. + -- + -- Otherwise for messages without a switch it will return + -- [enabled by default] . + + function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id; + -- Returns the first Primary Labeled_Span associated with the error + -- message. Otherwise it returns No_Labeled_Span. + + function Get_Human_Id (E : Error_Msg_Object) return String_Ptr; + -- Returns a longer human readable name for the switch associated with the + -- error message. + + function Get_Switch (E : Error_Msg_Object) return Switch_Type; + -- Returns the Switch information for the given error message + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id; + -- Returns the Switch information identifier for the given error message + + function Get_Switch_Id + (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id; + -- Returns the Switch information identifier based on the error kind and + -- the warning character. + -------------------------- -- Warning Mode Control -- -------------------------- @@ -422,6 +573,14 @@ package Erroutc is function SGR_Locus return String is (SGR_Seq (Color_Bold)); + function Get_SGR_Code (E_Msg : Error_Msg_Object) return String is + (if E_Msg.Warn_Err then SGR_Error + else + (case E_Msg.Kind is + when Warning | Style => SGR_Warning, + when Info => SGR_Note, + when others => SGR_Error)); + ----------------- -- Subprograms -- ----------------- @@ -513,7 +672,7 @@ package Erroutc is -- splits the line generating multiple lines of output, and in this case -- the last line has no terminating end of line character. - procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat); + procedure Output_Text_Within (Txt : String; Line_Length : Nat); -- Output the text in Txt, splitting it into lines of at most the size of -- Line_Length. @@ -549,6 +708,14 @@ package Erroutc is -- Note that the call has no effect for continuation messages (those whose -- first character is '\') except for the Has_Insertion_Line setting. + -- Definitions for valid message kind prefixes within error messages. + + Info_Prefix : constant String := "info: "; + Low_Prefix : constant String := "low: "; + Medium_Prefix : constant String := "medium: "; + High_Prefix : constant String := "high: "; + Style_Prefix : constant String := "(style) "; + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr); -- All error messages whose location is in the range From .. To (not -- including the end points) will be deleted from the error listing. diff --git a/gcc/ada/diagnostics-switch_repository.adb b/gcc/ada/errsw.adb index 1627de3..f4c4128 100644 --- a/gcc/ada/diagnostics-switch_repository.adb +++ b/gcc/ada/errsw.adb @@ -22,9 +22,10 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; -with Output; use Output; -package body Diagnostics.Switch_Repository is +with JSON_Utils; use JSON_Utils; +with Output; use Output; + +package body Errsw is Switches : constant array (Switch_Id) of Switch_Type := @@ -553,12 +554,6 @@ package body Diagnostics.Switch_Repository is return Switches (Id); end Get_Switch; - function Get_Switch (Diag : Diagnostic_Type) return Switch_Type is - - begin - return Get_Switch (Diag.Switch); - end Get_Switch; - ------------------- -- Get_Switch_Id -- ------------------- @@ -577,26 +572,6 @@ package body Diagnostics.Switch_Repository is return No_Switch_Id; end Get_Switch_Id; - ------------------- - -- Get_Switch_Id -- - ------------------- - - function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is - Switch_Name : constant String := - (if E.Warn_Chr = "$ " then "gnatel" - elsif E.Warn_Chr in "? " | " " then "" - elsif E.Kind in Erroutc.Warning | Erroutc.Info - then "gnatw" & E.Warn_Chr - elsif E.Kind in Erroutc.Style then "gnatw" & E.Warn_Chr - else ""); - begin - if Switch_Name /= "" then - return Get_Switch_Id (Switch_Name); - else - return No_Switch_Id; - end if; - end Get_Switch_Id; - ----------------------------- -- Print_Switch_Repository -- ----------------------------- @@ -687,4 +662,4 @@ package body Diagnostics.Switch_Repository is Write_Eol; end Print_Switch_Repository; -end Diagnostics.Switch_Repository; +end Errsw; diff --git a/gcc/ada/errsw.ads b/gcc/ada/errsw.ads new file mode 100644 index 0000000..b6d0130 --- /dev/null +++ b/gcc/ada/errsw.ads @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2025, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Types; use Types; + +package Errsw is + + type Status_Type is + (Active, + Deprecated); + + type Switch_Id is ( + No_Switch_Id, + gnatwb, + gnatwc, + gnatwd, + gnatwf, + gnatwg, + gnatwh, + gnatwi, + gnatwj, + gnatwk, + gnatwl, + gnatwm, + gnatwo, + gnatwp, + gnatwq, + gnatwr, + gnatwt, + gnatwu, + gnatwv, + gnatww, + gnatwx, + gnatwy, + gnatwz, + gnatw_dot_a, + gnatw_dot_b, + gnatw_dot_c, + gnatw_dot_f, + gnatw_dot_h, + gnatw_dot_i, + gnatw_dot_j, + gnatw_dot_k, + gnatw_dot_l, + gnatw_dot_m, + gnatw_dot_n, + gnatw_dot_o, + gnatw_dot_p, + gnatw_dot_q, + gnatw_dot_r, + gnatw_dot_s, + gnatw_dot_t, + gnatw_dot_u, + gnatw_dot_v, + gnatw_dot_w, + gnatw_dot_x, + gnatw_dot_y, + gnatw_dot_z, + gnatw_underscore_a, + gnatw_underscore_c, + gnatw_underscore_j, + gnatw_underscore_l, + gnatw_underscore_p, + gnatw_underscore_q, + gnatw_underscore_r, + gnatw_underscore_s, + gnaty, + gnatya, + gnatyb, + gnatyc, + gnatyd, + gnatye, + gnatyf, + gnatyh, + gnatyi, + gnatyk, + gnatyl, + gnatym, + gnatyn, + gnatyo, + gnatyp, + gnatyr, + gnatys, + gnatyu, + gnatyx, + gnatyz, + gnatyaa, + gnatybb, + gnatycc, + gnatydd, + gnatyii, + gnatyll, + gnatymm, + gnatyoo, + gnatyss, + gnatytt, + gnatel + ); + + subtype Active_Switch_Id is Switch_Id range gnatwb .. gnatel; + + type Switch_Type is record + + Status : Status_Type := Active; + -- The status will indicate whether the switch is currently active, + -- or has been deprecated. A deprecated switch will not control + -- diagnostics, and will not be emitted by the GNAT usage. + + Human_Id : String_Ptr := null; + -- The Human_Id will be a unique and stable string-based ID which + -- identifies the content of the switch within the switch registry. + -- This ID will appear in SARIF readers. + + Short_Name : String_Ptr := null; + -- The Short_Name will denote the -gnatXX name of the switch. + + Description : String_Ptr := null; + -- The description will contain the description of the switch, as it is + -- currently emitted by the GNAT usage. + + Documentation_Url : String_Ptr := null; + -- The documentation_url will point to the AdaCore documentation site + -- for the switch. + + end record; + + function Get_Switch (Id : Switch_Id) return Switch_Type; + + function Get_Switch_Id (Name : String) return Switch_Id; + + procedure Print_Switch_Repository; + +end Errsw; diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 5548d53..b5fd1a5 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -25,7 +25,9 @@ with Atree; use Atree; with Err_Vars; use Err_Vars; +with Errid; use Errid; with Erroutc; use Erroutc; +with Errsw; use Errsw; with Namet; use Namet; with Opt; use Opt; with Output; use Output; @@ -211,7 +213,11 @@ package body Errutil is Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, Deleted => False, - Kind => Error_Msg_Kind)); + Kind => Error_Msg_Kind, + Id => No_Diagnostic_Id, + Switch => No_Switch_Id, + Locations => No_Labeled_Span, + Fixes => No_Fix)); Cur_Msg := Errors.Last; Prev_Msg := No_Error_Msg; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7cb26ce..5450402 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4327,6 +4327,7 @@ package body Exp_Aggr is Typ : constant Entity_Id := Etype (N); Dims : constant Nat := Number_Dimensions (Typ); Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N); + Ctyp : constant Entity_Id := Component_Type (Typ); Static_Components : Boolean := True; @@ -4803,7 +4804,13 @@ package body Exp_Aggr is -- components because in this case will need to call the corresponding -- IP procedure. - if Has_Default_Init_Comps (N) then + if Has_Default_Init_Comps (N) + or else Present (Constructor_Name (Ctyp)) + or else (Is_Access_Type (Ctyp) + and then Present + (Constructor_Name + (Directly_Designated_Type (Ctyp)))) + then return; end if; @@ -4956,6 +4963,14 @@ package body Exp_Aggr is -- type using the computable sizes of the aggregate and its sub- -- aggregates. + function Build_Two_Pass_Aggr_Code + (Lhs : Node_Id; + Aggr_Typ : out Entity_Id) return List_Id; + -- The aggregate consists only of iterated associations and Lhs is an + -- expression containing the location of the anonymous object, which + -- may be built in place. Returns the dynamic subtype of the aggregate + -- in Aggr_Typ and the list of statements needed to build it. + procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id); -- Checks that the bounds of Aggr_Bounds are within the bounds defined -- by Index_Bounds. For null array aggregate (Ada 2022) check that the @@ -4983,7 +4998,7 @@ package body Exp_Aggr is -- built directly into the target of an assignment, the target must -- be free of side effects. N is the target of the assignment. - procedure Two_Pass_Aggregate_Expansion (N : Node_Id); + procedure Two_Pass_Aggregate_Expansion; -- If the aggregate consists only of iterated associations then the -- aggregate is constructed in two steps: -- a) Build an expression to compute the number of elements @@ -5053,6 +5068,221 @@ package body Exp_Aggr is Freeze_Itype (Agg_Type, N); end Build_Constrained_Type; + ------------------------------ + -- Build_Two_Pass_Aggr_Code -- + ------------------------------ + + function Build_Two_Pass_Aggr_Code + (Lhs : Node_Id; + Aggr_Typ : out Entity_Id) return List_Id + is + Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + Index_Base : constant Entity_Id := Base_Type (Index_Type); + Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Size_Type : constant Entity_Id := + Integer_Type_For + (Esize (Index_Base), Is_Unsigned_Type (Index_Base)); + + Assoc : Node_Id; + Incr : Node_Id; + Iter : Node_Id; + New_Comp : Node_Id; + One_Loop : Node_Id; + Iter_Id : Entity_Id; + + Aggr_Code : List_Id; + Size_Expr_Code : List_Id; + + begin + Size_Expr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Size_Id, + Object_Definition => New_Occurrence_Of (Size_Type, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + -- First pass: execute the iterators to count the number of elements + -- that will be generated. + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Iter_Id := Defining_Identifier (Iter); + Incr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Size_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Avoid using the same iterator definition in both loops by + -- creating a new iterator for each loop and mapping it over the + -- original iterator references. + + One_Loop := + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => + New_Copy_Tree (Iter, + Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), + Statements => New_List (Incr)); + + Append (One_Loop, Size_Expr_Code); + Next (Assoc); + end loop; + + Insert_Actions (N, Size_Expr_Code); + + -- Build a constrained subtype with the bounds deduced from + -- the size computed above and declare the aggregate object. + -- The index type is some discrete type, so the bounds of the + -- constrained subtype are computed as T'Val (integer bounds). + + declare + -- Pos_Lo := Index_Type'Pos (Index_Type'First) + + Pos_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First))); + + -- Corresponding index value, i.e. Index_Type'First + + Aggr_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First); + + -- Pos_Hi := Pos_Lo + Size - 1 + + Pos_Hi : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => Pos_Lo, + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Corresponding index value + + Aggr_Hi : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (Pos_Hi)); + + begin + Aggr_Typ := Make_Temporary (Loc, 'T'); + + Insert_Action (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Aggr_Typ, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => + New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi)))))); + end; + + -- Second pass: use the iterators to generate the elements of the + -- aggregate. We assume that the second evaluation of each iterator + -- generates the same number of elements as the first pass, and thus + -- consider that the execution is erroneous (even if the RM does not + -- state this explicitly) if the number of elements generated differs + -- between first and second pass. + + Assoc := First (Component_Associations (N)); + + -- Initialize insertion position to first array component + + Aggr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Index_Id, + Object_Definition => + New_Occurrence_Of (Index_Type, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Lhs), + Attribute_Name => Name_First))); + + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Iter_Id := Defining_Identifier (Iter); + New_Comp := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Copy_Tree (Lhs), + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc))), + Expression => Copy_Separate_Tree (Expression (Assoc))); + + -- Arrange for the component to be adjusted if need be (the call + -- will be generated by Make_Tag_Ctrl_Assignment). + + if Needs_Finalization (Ctyp) + and then not Is_Inherently_Limited_Type (Ctyp) + then + Set_No_Finalize_Actions (New_Comp); + else + Set_No_Ctrl_Actions (New_Comp); + end if; + + -- Advance index position for insertion + + Incr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Index_Id, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Succ, + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc)))); + + -- Add guard to skip last increment when upper bound is reached + + Incr := + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Index_Id, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Last)), + Then_Statements => New_List (Incr)); + + -- Avoid using the same iterator definition in both loops by + -- creating a new iterator for each loop and mapping it over + -- the original iterator references. + + One_Loop := + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => + New_Copy_Tree (Iter, + Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), + Statements => New_List (New_Comp, Incr)); + + Append (One_Loop, Aggr_Code); + Next (Assoc); + end loop; + + return Aggr_Code; + end Build_Two_Pass_Aggr_Code; + ------------------ -- Check_Bounds -- ------------------ @@ -5596,214 +5826,98 @@ package body Exp_Aggr is -- Two_Pass_Aggregate_Expansion -- ---------------------------------- - procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Comp_Type : constant Entity_Id := Etype (N); - Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); - Index_Type : constant Entity_Id := Etype (First_Index (Etype (N))); - Index_Base : constant Entity_Id := Base_Type (Index_Type); - Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); - Size_Type : constant Entity_Id := - Integer_Type_For - (Esize (Index_Base), Is_Unsigned_Type (Index_Base)); - TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); - - Assoc : Node_Id := First (Component_Associations (N)); - Incr : Node_Id; - Iter : Node_Id; - New_Comp : Node_Id; - One_Loop : Node_Id; - Iter_Id : Entity_Id; - - Size_Expr_Code : List_Id; - Insertion_Code : List_Id := New_List; + procedure Two_Pass_Aggregate_Expansion is + Aggr_Code : List_Id; + Aggr_Typ : Entity_Id; + Lhs : Node_Id; + Obj_Id : Entity_Id; + Par : Node_Id; begin - Size_Expr_Code := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Size_Id, - Object_Definition => New_Occurrence_Of (Size_Type, Loc), - Expression => Make_Integer_Literal (Loc, 0))); - - -- First pass: execute the iterators to count the number of elements - -- that will be generated. - - while Present (Assoc) loop - Iter := Iterator_Specification (Assoc); - Iter_Id := Defining_Identifier (Iter); - Incr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Size_Id, Loc), - Expression => - Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Size_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - - -- Avoid using the same iterator definition in both loops by - -- creating a new iterator for each loop and mapping it over the - -- original iterator references. - - One_Loop := Make_Implicit_Loop_Statement (N, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Iterator_Specification => - New_Copy_Tree (Iter, - Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), - Statements => New_List (Incr)); - - Append (One_Loop, Size_Expr_Code); - Next (Assoc); + Par := Parent (N); + while Nkind (Par) = N_Qualified_Expression loop + Par := Parent (Par); end loop; - Insert_Actions (N, Size_Expr_Code); - - -- Build a constrained subtype with the bounds deduced from - -- the size computed above and declare the aggregate object. - -- The index type is some discrete type, so the bounds of the - -- constrained subtype are computed as T'Val (integer bounds). - - declare - -- Pos_Lo := Index_Type'Pos (Index_Type'First) - - Pos_Lo : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Pos, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First))); - - -- Corresponding index value, i.e. Index_Type'First - - Aggr_Lo : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First); - - -- Pos_Hi := Pos_Lo + Size - 1 - - Pos_Hi : constant Node_Id := - Make_Op_Add (Loc, - Left_Opnd => Pos_Lo, - Right_Opnd => - Make_Op_Subtract (Loc, - Left_Opnd => New_Occurrence_Of (Size_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - - -- Corresponding index value + -- If the aggregate is the initialization expression of an object + -- declaration, we always build the aggregate in place, although + -- this is required only for immutably limited types and types + -- that need finalization, see RM 7.6(17.2/3-17.3/3). - Aggr_Hi : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Val, - Expressions => New_List (Pos_Hi)); - - SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); - SubD : constant Node_Id := - Make_Subtype_Declaration (Loc, - Defining_Identifier => SubE, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Etype (Comp_Type), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint - (Loc, - Constraints => - New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi))))); - - -- Create a temporary array of the above subtype which - -- will be used to capture the aggregate assignments. - - TmpD : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => TmpE, - Object_Definition => New_Occurrence_Of (SubE, Loc)); - - begin - Insert_Actions (N, New_List (SubD, TmpD)); - end; - - -- Second pass: use the iterators to generate the elements of the - -- aggregate. Insertion index starts at Index_Type'First. We - -- assume that the second evaluation of each iterator generates - -- the same number of elements as the first pass, and consider - -- that the execution is erroneous (even if the RM does not state - -- this explicitly) if the number of elements generated differs - -- between first and second pass. - - Assoc := First (Component_Associations (N)); + if Nkind (Par) = N_Object_Declaration then + Obj_Id := Defining_Identifier (Par); + Lhs := New_Occurrence_Of (Obj_Id, Loc); + Set_Assignment_OK (Lhs); + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); - -- Initialize insertion position to first array component. + -- Save the last assignment statement associated with the + -- aggregate when building a controlled object. This last + -- assignment is used by the finalization machinery when + -- marking an object as successfully initialized. - Insertion_Code := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Index_Id, - Object_Definition => - New_Occurrence_Of (Index_Type, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First))); + if Needs_Finalization (Typ) then + Mutate_Ekind (Obj_Id, E_Variable); + Set_Last_Aggregate_Assignment (Obj_Id, Last (Aggr_Code)); + end if; - while Present (Assoc) loop - Iter := Iterator_Specification (Assoc); - Iter_Id := Defining_Identifier (Iter); - New_Comp := Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (TmpE, Loc), - Expressions => - New_List (New_Occurrence_Of (Index_Id, Loc))), - Expression => Copy_Separate_Tree (Expression (Assoc))); + -- If a transient scope has been created around the declaration, + -- we need to attach the code to it so that finalization actions + -- of the declaration will be inserted after it; otherwise, we + -- directly insert it after the declaration. In both cases, the + -- code will be analyzed after the declaration is processed, i.e. + -- once the actual subtype of the object is established. - -- Advance index position for insertion. + if Scope_Is_Transient and then Par = Node_To_Be_Wrapped then + Store_After_Actions_In_Scope_Without_Analysis (Aggr_Code); + else + Insert_List_After (Par, Aggr_Code); + end if; - Incr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Index_Id, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Succ, - Expressions => - New_List (New_Occurrence_Of (Index_Id, Loc)))); + Set_Etype (N, Aggr_Typ); + Set_No_Initialization (Par); - -- Add guard to skip last increment when upper bound is reached. + -- Likewise if it is the qualified expression of an allocator but, + -- in this case, we wait until after Expand_Allocator_Expression + -- rewrites the allocator as the initialization expression of an + -- object declaration, so that we have the left-hand side. - Incr := Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Index_Id, Loc), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Last)), - Then_Statements => New_List (Incr)); + elsif Nkind (Par) = N_Allocator then + if Nkind (Parent (Par)) = N_Object_Declaration + and then + not Comes_From_Source (Defining_Identifier (Parent (Par))) + then + Obj_Id := Defining_Identifier (Parent (Par)); + Lhs := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc)); + Set_Assignment_OK (Lhs); + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); - -- Avoid using the same iterator definition in both loops by - -- creating a new iterator for each loop and mapping it over the - -- original iterator references. + Insert_Actions_After (Parent (Par), Aggr_Code); - One_Loop := Make_Implicit_Loop_Statement (N, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Iterator_Specification => - New_Copy_Tree (Iter, - Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), - Statements => New_List (New_Comp, Incr)); + Set_Expression (Par, New_Occurrence_Of (Aggr_Typ, Loc)); + Set_No_Initialization (Par); + end if; - Append (One_Loop, Insertion_Code); - Next (Assoc); - end loop; + -- Otherwise we create a temporary for the anonymous object and + -- replace the aggregate with the temporary. - Insert_Actions (N, Insertion_Code); + else + Obj_Id := Make_Temporary (Loc, 'A', N); + Lhs := New_Occurrence_Of (Obj_Id, Loc); + Set_Assignment_OK (Lhs); - -- Depending on context this may not work for build-in-place - -- arrays ??? + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); + Prepend_To (Aggr_Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => New_Occurrence_Of (Aggr_Typ, Loc))); - Rewrite (N, New_Occurrence_Of (TmpE, Loc)); + Insert_Actions (N, Aggr_Code); + Rewrite (N, Lhs); + Analyze_And_Resolve (N, Aggr_Typ); + end if; end Two_Pass_Aggregate_Expansion; -- Local variables @@ -5829,7 +5943,7 @@ package body Exp_Aggr is -- Aggregates that require a two-pass expansion are handled separately elsif Is_Two_Pass_Aggregate (N) then - Two_Pass_Aggregate_Expansion (N); + Two_Pass_Aggregate_Expansion; return; -- Do not attempt expansion if error already detected. We may reach this @@ -6002,12 +6116,11 @@ package body Exp_Aggr is -- static type imposed by the context. declare - Itype : constant Entity_Id := Etype (N); Index : Node_Id; Needs_Type : Boolean := False; begin - Index := First_Index (Itype); + Index := First_Index (Typ); while Present (Index) loop if not Is_OK_Static_Subtype (Etype (Index)) then Needs_Type := True; @@ -6019,7 +6132,7 @@ package body Exp_Aggr is if Needs_Type then Build_Constrained_Type (Positional => True); - Rewrite (N, Unchecked_Convert_To (Itype, N)); + Rewrite (N, Unchecked_Convert_To (Typ, N)); Analyze (N); end if; end; @@ -6147,7 +6260,7 @@ package body Exp_Aggr is then Tmp := Name (Parent_Node); - if Etype (Tmp) /= Etype (N) then + if Etype (Tmp) /= Typ then Apply_Length_Check (N, Etype (Tmp)); if Nkind (N) = N_Raise_Constraint_Error then @@ -7362,7 +7475,7 @@ package body Exp_Aggr is -- Likewise if the aggregate is the qualified expression of an allocator -- but, in this case, we wait until after Expand_Allocator_Expression -- rewrites the allocator as the initialization expression of an object - -- declaration to have the left hand side. + -- declaration, so that we have the left-hand side. elsif Nkind (Par) = N_Allocator then if Nkind (Parent (Par)) = N_Object_Declaration @@ -7971,7 +8084,8 @@ package body Exp_Aggr is Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Typ, - Duplicate_Subexpr (Parent_Expr, True)), + Duplicate_Subexpr + (Parent_Expr, Name_Req => True)), Selector_Name => New_Occurrence_Of (Comp, Loc)); Append_To (Comps, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b896228..f1f8424 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Accessibility; use Accessibility; +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -88,8 +89,10 @@ package body Exp_Attr is function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is (Header_Num (Id mod Map_Size)); - -- Cache used to avoid building duplicate subprograms for a single - -- type/streaming-attribute pair. + -- Caches used to avoid building duplicate subprograms for a single + -- type/attribute pair (where the attribute is either Put_Image or + -- one of the four streaming attributes). The type used as a key in + -- in accessing these maps should not be the entity of a subtype. package Read_Map is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, @@ -282,8 +285,8 @@ package body Exp_Attr is (In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit) -- If subp declared in unit body, then we don't want to refer -- to it from within unit spec so return False in that case. - and then not (Body_Required (Attr_Ref_Unit) - and not Body_Required (Subp_Unit))); + and then not (not Is_Body (Unit (Attr_Ref_Unit)) + and Is_Body (Unit (Subp_Unit)))); -- Returns True if it is ok to refer to a cached subprogram declared in -- Subp_Unit from the point of an attribute reference occurring in -- Attr_Ref_Unit. Both arguments are usually N_Compilation_Nodes, @@ -4669,7 +4672,7 @@ package body Exp_Attr is end if; if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Input_Map.Set (P_Type, Fname); + Cached_Attribute_Ops.Input_Map.Set (U_Type, Fname); end if; end Input; @@ -4983,6 +4986,316 @@ package body Exp_Attr is Analyze_And_Resolve (N, Typ); + ---------- + -- Make -- + ---------- + + when Attribute_Make => + declare + Params : List_Id; + Param : Node_Id; + Par : Node_Id; + Construct : Entity_Id; + Obj : Node_Id := Empty; + Make_Expr : Node_Id := N; + + Formal : Entity_Id; + Replace_Expr : Node_Id; + Init_Param : Node_Id; + Construct_Call : Node_Id; + Curr_Nam : Node_Id := Empty; + + function Replace_Formal_Ref + (N : Node_Id) return Traverse_Result; + + function Replace_Formal_Ref + (N : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (N) + and then Chars (Formal) = Chars (N) + then + Rewrite (N, + New_Copy_Tree (Replace_Expr)); + end if; + + return OK; + end Replace_Formal_Ref; + + procedure Search_And_Replace_Formal is new + Traverse_Proc (Replace_Formal_Ref); + + begin + -- Remove side effects for constructor call + + Param := First (Expressions (N)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association then + Remove_Side_Effects (Explicit_Actual_Parameter (Param), + Check_Side_Effects => False); + else + Remove_Side_Effects (Param, Check_Side_Effects => False); + end if; + + Next (Param); + end loop; + + -- Construct the parameters list + + Params := New_Copy_List (Expressions (N)); + if Is_Empty_List (Params) then + Params := New_List; + end if; + + -- Identify the enclosing parent for the non-copy cases + + Par := Parent (N); + if Nkind (Par) = N_Qualified_Expression then + Par := Parent (Par); + Make_Expr := Par; + end if; + if Nkind (Par) = N_Allocator then + Par := Parent (Par); + Curr_Nam := Make_Explicit_Dereference + (Loc, Prefix => Empty); + Obj := Curr_Nam; + end if; + + declare + Base_Obj : Node_Id := Empty; + Typ_Comp : Entity_Id; + Agg_Comp : Entity_Id; + Comp_Nam : Node_Id := Empty; + begin + while Nkind (Par) not in N_Object_Declaration + | N_Assignment_Statement + loop + if Nkind (Par) = N_Aggregate then + Typ_Comp := First_Entity (Etype (Par)); + Agg_Comp := First (Expressions (Par)); + loop + if No (Agg_Comp) then + return; + end if; + + if Agg_Comp = Make_Expr then + Comp_Nam := + Make_Selected_Component (Loc, + Prefix => Empty, + Selector_Name => + New_Occurrence_Of (Typ_Comp, Loc)); + + Make_Expr := Parent (Make_Expr); + Par := Parent (Par); + exit; + end if; + + Next_Entity (Typ_Comp); + Next (Agg_Comp); + end loop; + elsif Nkind (Par) = N_Component_Association then + Comp_Nam := + Make_Selected_Component (Loc, + Prefix => Empty, + Selector_Name => + Make_Identifier (Loc, + (Chars (First (Choices (Par)))))); + + Make_Expr := Parent (Parent (Make_Expr)); + Par := Parent (Parent (Par)); + else + declare + Temp : constant Entity_Id := + Make_Temporary (Loc, 'T', N); + begin + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Typ, Loc), + Expression => + New_Copy_Tree (N))), + Expression => New_Occurrence_Of (Temp, Loc))); + Analyze_And_Resolve (N); + return; + end; + end if; + + if No (Curr_Nam) then + Curr_Nam := Comp_Nam; + Obj := Curr_Nam; + elsif Has_Prefix (Curr_Nam) then + Set_Prefix (Curr_Nam, Comp_Nam); + Curr_Nam := Comp_Nam; + end if; + end loop; + + Base_Obj := (case Nkind (Par) is + when N_Assignment_Statement => + New_Copy_Tree (Name (Par)), + when N_Object_Declaration => + New_Occurrence_Of + (Defining_Identifier (Par), Loc), + when others => (raise Program_Error)); + + if Present (Curr_Nam) then + Set_Prefix (Curr_Nam, Base_Obj); + else + Obj := Base_Obj; + end if; + end; + + Prepend_To (Params, Obj); + + -- Find the constructor we are interested in by doing a + -- pseudo-pass to resolve the constructor call. + + declare + Dummy_Params : List_Id := New_Copy_List (Expressions (N)); + Dummy_Self : Node_Id; + Dummy_Block : Node_Id; + Dummy_Call : Node_Id; + Dummy_Id : Entity_Id := Make_Temporary (Loc, 'D', N); + begin + if Is_Empty_List (Dummy_Params) then + Dummy_Params := New_List; + end if; + + Dummy_Self := Make_Object_Declaration (Loc, + Defining_Identifier => Dummy_Id, + Object_Definition => + New_Occurrence_Of (Typ, Loc)); + Prepend_To (Dummy_Params, New_Occurrence_Of (Dummy_Id, Loc)); + + Dummy_Call := Make_Procedure_Call_Statement (Loc, + Parameter_Associations => Dummy_Params, + Name => + (if not Has_Prefix (Pref) then + Make_Identifier (Loc, + Chars (Constructor_Name (Typ))) + else + Make_Expanded_Name (Loc, + Chars => + Chars (Constructor_Name (Typ)), + Prefix => + New_Copy_Tree (Prefix (Pref)), + Selector_Name => + Make_Identifier (Loc, + Chars (Constructor_Name (Typ)))))); + Set_Is_Expanded_Constructor_Call (Dummy_Call, True); + + Dummy_Block := Make_Block_Statement (Loc, + Declarations => New_List (Dummy_Self), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Dummy_Call))); + + Expander_Active := False; + + Insert_After_And_Analyze + (Enclosing_Declaration_Or_Statement (Par), Dummy_Block); + + Expander_Active := True; + + -- Finally, we can get the constructor based on our pseudo-pass + + Construct := Entity (Name (Dummy_Call)); + + -- Replace the Typ'Make attribute with an aggregate featuring + -- then relevant aggregate from the correct constructor's + -- Inializeaspect if it is present - otherwise, simply use a + -- box. + + if Has_Aspect (Construct, Aspect_Initialize) then + Rewrite (N, + New_Copy_Tree + (Find_Value_Of_Aspect (Construct, Aspect_Initialize))); + + Param := Next (First (Params)); + Formal := Next_Entity (First_Entity (Construct)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association then + Formal := Selector_Name (Param); + Replace_Expr := Explicit_Actual_Parameter (Param); + else + Replace_Expr := Param; + end if; + + Init_Param := First (Component_Associations (N)); + while Present (Init_Param) loop + Search_And_Replace_Formal (Expression (Init_Param)); + + Next (Init_Param); + end loop; + + if Nkind (Param) /= N_Parameter_Association then + Next_Entity (Formal); + end if; + Next (Param); + end loop; + + Init_Param := First (Component_Associations (N)); + while Present (Init_Param) loop + if Nkind (Expression (Init_Param)) = N_Attribute_Reference + and then Attribute_Name + (Expression (Init_Param)) = Name_Make + then + Insert_After (Par, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + New_Copy_Tree (First (Params)), + Selector_Name => + Make_Identifier (Loc, + Chars (First (Choices (Init_Param))))), + Expression => + New_Copy_Tree (Expression (Init_Param)))); + + Rewrite (Expression (Init_Param), + Make_Aggregate (Loc, + Expressions => New_List, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => + New_List (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True)))); + end if; + + Next (Init_Param); + end loop; + else + Rewrite (N, + Make_Aggregate (Loc, + Expressions => New_List, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True)))); + end if; + + -- Rewrite this block to be null and pretend it didn't happen + + Rewrite (Dummy_Block, Make_Null_Statement (Loc)); + end; + + Analyze_And_Resolve (N, Typ); + + -- Finally, insert the constructor call + + Construct_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Construct, Loc), + Parameter_Associations => Params); + + Set_Is_Expanded_Constructor_Call (Construct_Call); + Insert_After (Par, Construct_Call); + end; + -------------- -- Mantissa -- -------------- @@ -5750,7 +6063,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Output_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Output_Map.Set (U_Type, Pname); end if; end Output; @@ -6669,7 +6982,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Read_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname); end if; end Read; @@ -8349,7 +8662,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Write_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Write_Map.Set (U_Type, Pname); end if; end Write; @@ -8600,10 +8913,10 @@ package body Exp_Attr is Rewrite (N, Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Pref, True), + Prefix => Duplicate_Subexpr (Pref, Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Pref, True), + Prefix => Duplicate_Subexpr (Pref, Name_Req => True), Attribute_Name => Name_Component_Size))); Analyze_And_Resolve (N, Typ); end if; @@ -8951,15 +9264,22 @@ package body Exp_Attr is return Empty; end if; - if Nam = TSS_Stream_Read then - Ent := Cached_Attribute_Ops.Read_Map.Get (Typ); - elsif Nam = TSS_Stream_Write then - Ent := Cached_Attribute_Ops.Write_Map.Get (Typ); - elsif Nam = TSS_Stream_Input then - Ent := Cached_Attribute_Ops.Input_Map.Get (Typ); - elsif Nam = TSS_Stream_Output then - Ent := Cached_Attribute_Ops.Output_Map.Get (Typ); - end if; + declare + function U_Base return Entity_Id is + (Underlying_Type (Base_Type (Typ))); + -- Return the right type node for use in a C_A_O map lookup. + -- In particular, we do not want the entity for a subtype. + begin + if Nam = TSS_Stream_Read then + Ent := Cached_Attribute_Ops.Read_Map.Get (U_Base); + elsif Nam = TSS_Stream_Write then + Ent := Cached_Attribute_Ops.Write_Map.Get (U_Base); + elsif Nam = TSS_Stream_Input then + Ent := Cached_Attribute_Ops.Input_Map.Get (U_Base); + elsif Nam = TSS_Stream_Output then + Ent := Cached_Attribute_Ops.Output_Map.Get (U_Base); + end if; + end; Cached_Attribute_Ops.Validate_Cached_Candidate (Subp => Ent, Attr_Ref => Attr_Ref); diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index a0dbcad..b00e75e 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1194,8 +1194,6 @@ package body Exp_Ch11 is Prefix => New_Occurrence_Of (Id, Loc), Attribute_Name => Name_Unrestricted_Access))))); - Set_Register_Exception_Call (Id, First (L)); - if not Is_Library_Level_Entity (Id) then Flag_Id := Make_Defining_Identifier (Loc, diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index bc46fd3..d884e75 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2652,11 +2652,9 @@ package body Exp_Ch3 is -- may have an incomplete type. In that case, it must also be -- replaced by the formal of the Init_Proc. - if Nkind (Parent (Rec_Type)) = N_Full_Type_Declaration - and then Present (Incomplete_View (Parent (Rec_Type))) - then + if Present (Incomplete_View (Rec_Type)) then Append_Elmt ( - N => Incomplete_View (Parent (Rec_Type)), + N => Incomplete_View (Rec_Type), To => Map); Append_Elmt ( N => Defining_Identifier @@ -3765,6 +3763,21 @@ package body Exp_Ch3 is Actions := Build_Assignment (Id, Expression (Decl)); end if; + -- Expand components with constructors to have the 'Make + -- attribute. + + elsif Present (Constructor_Name (Typ)) + and then Present (Default_Constructor (Typ)) + then + Set_Expression (Decl, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Make, + Prefix => + Subtype_Indication + (Component_Definition (Decl)))); + Analyze (Expression (Decl)); + Actions := Build_Assignment (Id, Expression (Decl)); + -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size -- components are filled in with the corresponding rep-item -- expression of the concurrent type (if any). @@ -5423,18 +5436,12 @@ package body Exp_Ch3 is -- with an initial value, its Init_Proc will never be called. The -- initial value itself may have been expanded into assignments, -- in which case the declaration has the No_Initialization flag. - -- The exception is when the initial value is a 2-pass aggregate, - -- because the special expansion used for it creates a temporary - -- that needs a fully-fledged initialization. if Is_Itype (Base) and then Nkind (Associated_Node_For_Itype (Base)) = N_Object_Declaration and then - ((Present (Expression (Associated_Node_For_Itype (Base))) - and then not - Is_Two_Pass_Aggregate - (Expression (Associated_Node_For_Itype (Base)))) + (Present (Expression (Associated_Node_For_Itype (Base))) or else No_Initialization (Associated_Node_For_Itype (Base))) then null; @@ -6760,12 +6767,13 @@ package body Exp_Ch3 is procedure Expand_N_Object_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Def_Id : constant Entity_Id := Defining_Identifier (N); - Expr : constant Node_Id := Expression (N); Obj_Def : constant Node_Id := Object_Definition (N); Typ : constant Entity_Id := Etype (Def_Id); Base_Typ : constant Entity_Id := Base_Type (Typ); Next_N : constant Node_Id := Next (N); + Expr : Node_Id := Expression (N); + Special_Ret_Obj : constant Boolean := Is_Special_Return_Object (Def_Id); -- If this is a special return object, it will be allocated differently -- and ultimately rewritten as a renaming, so initialization activities @@ -7482,7 +7490,11 @@ package body Exp_Ch3 is -- Don't do anything for deferred constants. All proper actions will be -- expanded during the full declaration. - if No (Expr) and Constant_Present (N) then + if No (Expr) + and then Constant_Present (N) + and then (No (Constructor_Name (Typ)) + or else No (Default_Constructor (Typ))) + then return; end if; @@ -7507,6 +7519,21 @@ package body Exp_Ch3 is return; end if; + -- Expand objects with default constructors to have the 'Make + -- attribute. + + if Comes_From_Source (N) + and then No (Expr) + and then Present (Constructor_Name (Typ)) + and then Present (Default_Constructor (Typ)) + then + Expr := Make_Attribute_Reference (Loc, + Attribute_Name => Name_Make, + Prefix => Object_Definition (N)); + Set_Expression (N, Expr); + Analyze_And_Resolve (Expr); + end if; + -- Make shared memory routines for shared passive variable if Is_Shared_Passive (Def_Id) then @@ -8293,12 +8320,15 @@ package body Exp_Ch3 is -- where the object has been initialized by a call to a function -- returning on the primary stack (see Expand_Ctrl_Function_Call) -- since no copy occurred, given that the type is by-reference. + -- Likewise if it is initialized by a 2-pass aggregate, since the + -- actual initialization will only occur during the second pass. -- Similarly, no adjustment is needed if we are going to rewrite -- the object declaration into a renaming declaration. if Needs_Finalization (Typ) and then not Is_Inherently_Limited_Type (Typ) and then Nkind (Expr_Q) /= N_Function_Call + and then not Is_Two_Pass_Aggregate (Expr_Q) and then not Rewrite_As_Renaming then Adj_Call := diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 82978c7..01be3df 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -769,7 +769,6 @@ package body Exp_Ch4 is -- Local variables Aggr_In_Place : Boolean; - Container_Aggr : Boolean; Delayed_Cond_Expr : Boolean; TagT : Entity_Id := Empty; @@ -865,13 +864,15 @@ package body Exp_Ch4 is Aggr_In_Place := Is_Delayed_Aggregate (Exp); Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (Exp); - Container_Aggr := Nkind (Exp) = N_Aggregate - and then Has_Aspect (T, Aspect_Aggregate); - -- An allocator with a container aggregate as qualified expression must - -- be rewritten into the form expected by Expand_Container_Aggregate. + -- An allocator with a container aggregate, resp. a 2-pass aggregate, + -- as qualified expression must be rewritten into the form expected by + -- Expand_Container_Aggregate, resp. Two_Pass_Aggregate_Expansion. - if Container_Aggr then + if Nkind (Exp) = N_Aggregate + and then (Has_Aspect (T, Aspect_Aggregate) + or else Is_Two_Pass_Aggregate (Exp)) + then Temp := Make_Temporary (Loc, 'P', N); Set_Analyzed (Exp, False); Insert_Action (N, @@ -4490,6 +4491,15 @@ package body Exp_Ch4 is Error_Msg_N ("?_a?use of an anonymous access type allocator", N); end if; + -- Here we set no initialization on types with constructors since we + -- generate initialization for the separately. + + if Present (Constructor_Name (Directly_Designated_Type (PtrT))) + and then Nkind (Expression (N)) = N_Identifier + then + Set_No_Initialization (N, False); + end if; + -- RM E.2.2(17). We enforce that the expected type of an allocator -- shall not be a remote access-to-class-wide-limited-private type. -- We probably shouldn't be doing this legality check during expansion, @@ -13291,10 +13301,12 @@ package body Exp_Ch4 is Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, - Aliased_Present => Aliased_Present (Decl), + Aliased_Present => True, Constant_Present => Constant_Present (Decl), Object_Definition => New_Copy_Tree (Object_Definition (Decl)), Expression => Relocate_Node (Expr)); + -- We make the object unconditionally aliased to avoid dangling bound + -- issues when its nominal subtype is an unconstrained array type. Master_Node_Decl : Node_Id; Master_Node_Id : Entity_Id; @@ -13309,6 +13321,11 @@ package body Exp_Ch4 is Insert_Action (Expr, Obj_Decl); + -- The object can never be local to an elaboration routine at library + -- level since we will take 'Unrestricted_Access of it. + + Set_Is_Statically_Allocated (Obj_Id, Is_Library_Level_Entity (Obj_Id)); + -- If the object needs finalization, we need to insert its Master_Node -- manually because 1) the machinery in Exp_Ch7 will not pick it since -- it will be declared in the arm of a conditional statement and 2) we @@ -15035,10 +15052,11 @@ package body Exp_Ch4 is -- Handle entities from the limited view - Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right)); + Orig_Right_Type : constant Entity_Id := + Base_Type (Available_View (Etype (Right))); Full_R_Typ : Entity_Id; - Left_Type : Entity_Id := Available_View (Etype (Left)); + Left_Type : Entity_Id := Base_Type (Available_View (Etype (Left))); Right_Type : Entity_Id := Orig_Right_Type; Obj_Tag : Node_Id; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 06616ea..3d8a542 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1039,7 +1039,8 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr_Move_Checks (Larray, True), + Duplicate_Subexpr_Move_Checks + (Larray, Name_Req => True), Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => @@ -1054,7 +1055,8 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr_Move_Checks (Rarray, True), + Duplicate_Subexpr_Move_Checks + (Rarray, Name_Req => True), Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => @@ -1396,7 +1398,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Left_Lo))), Attribute_Name => Name_Address); @@ -1405,7 +1407,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Left_Lo))), Attribute_Name => Name_Bit); @@ -1414,7 +1416,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Rarray, True), + Duplicate_Subexpr (Rarray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Right_Lo))), Attribute_Name => Name_Address); @@ -1423,7 +1425,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Rarray, True), + Duplicate_Subexpr (Rarray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Right_Lo))), Attribute_Name => Name_Bit); @@ -1439,11 +1441,11 @@ package body Exp_Ch5 is Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Component_Size)); begin @@ -1527,11 +1529,11 @@ package body Exp_Ch5 is Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Attribute_Name => Name_Component_Size)); L_Arg, R_Arg, Call : Node_Id; @@ -1582,7 +1584,7 @@ package body Exp_Ch5 is end if; return Make_Assignment_Statement (Loc, - Name => Duplicate_Subexpr (Larray, True), + Name => Duplicate_Subexpr (Larray, Name_Req => True), Expression => Unchecked_Convert_To (L_Typ, Call)); end Expand_Assign_Array_Bitfield_Fast; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7e46454..f85d977 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2470,11 +2470,6 @@ package body Exp_Ch6 is -- (and ensure that we have an activation chain defined for tasks -- and a Master variable). - -- Currently we limit such functions to those with inherently - -- limited result subtypes, but eventually we plan to expand the - -- functions that are treated as build-in-place to include other - -- composite result types. - -- But do not do it here for intrinsic subprograms since this will -- be done properly after the subprogram is expanded. @@ -8562,12 +8557,10 @@ package body Exp_Ch6 is procedure Make_Build_In_Place_Call_In_Anonymous_Context (Function_Call : Node_Id) is - Loc : constant Source_Ptr := Sloc (Function_Call); - Func_Call : constant Node_Id := Unqual_Conv (Function_Call); - Function_Id : Entity_Id; - Result_Subt : Entity_Id; - Return_Obj_Id : Entity_Id; - Return_Obj_Decl : Entity_Id; + Loc : constant Source_Ptr := Sloc (Function_Call); + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); + Function_Id : Entity_Id; + Result_Subt : Entity_Id; begin -- If the call has already been processed to add build-in-place actuals @@ -8580,10 +8573,6 @@ package body Exp_Ch6 is return; end if; - -- Mark the call as processed as a build-in-place call - - Set_Is_Expanded_Build_In_Place_Call (Func_Call); - if Is_Entity_Name (Name (Func_Call)) then Function_Id := Entity (Name (Func_Call)); @@ -8601,8 +8590,13 @@ package body Exp_Ch6 is -- If the build-in-place function returns a controlled object, then the -- object needs to be finalized immediately after the context. Since -- this case produces a transient scope, the servicing finalizer needs - -- to name the returned object. Create a temporary which is initialized - -- with the function call: + -- to name the returned object. + + -- If the build-in-place function returns a definite subtype, then an + -- object also needs to be created and an access value designating it + -- passed as an actual. + + -- Create a temporary which is initialized with the function call: -- -- Temp_Id : Func_Type := BIP_Func_Call; -- @@ -8610,75 +8604,25 @@ package body Exp_Ch6 is -- the expander using the appropriate mechanism in Make_Build_In_Place_ -- Call_In_Object_Declaration. - if Needs_Finalization (Result_Subt) then + if Needs_Finalization (Result_Subt) + or else Caller_Known_Size (Func_Call, Result_Subt) + then declare Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); - Temp_Decl : Node_Id; - - begin - -- Reset the guard on the function call since the following does - -- not perform actual call expansion. - - Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); - - Temp_Decl := + Temp_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Id, - Object_Definition => - New_Occurrence_Of (Result_Subt, Loc), - Expression => - New_Copy_Tree (Function_Call)); + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Result_Subt, Loc), + Expression => Relocate_Node (Function_Call)); + begin + Set_Assignment_OK (Temp_Decl); Insert_Action (Function_Call, Temp_Decl); - Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); Analyze (Function_Call); end; - -- When the result subtype is definite, an object of the subtype is - -- declared and an access value designating it is passed as an actual. - - elsif Caller_Known_Size (Func_Call, Result_Subt) then - - -- Create a temporary object to hold the function result - - Return_Obj_Id := Make_Temporary (Loc, 'R'); - Set_Etype (Return_Obj_Id, Result_Subt); - - Return_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Result_Subt, Loc)); - - Set_No_Initialization (Return_Obj_Decl); - - Insert_Action (Func_Call, Return_Obj_Decl); - - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. - - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - - Add_Collection_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id); - - Add_Task_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); - - -- Add an implicit actual to the function call that provides access - -- to the caller's return object. - - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc)); - - pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); - pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); - -- When the result subtype is unconstrained, the function must allocate -- the return object in the secondary stack, so appropriate implicit -- parameters are added to the call to indicate that. A transient @@ -8703,6 +8647,10 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Empty); + -- Mark the call as processed as a build-in-place call + + Set_Is_Expanded_Build_In_Place_Call (Func_Call); + pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); end if; @@ -9909,6 +9857,13 @@ package body Exp_Ch6 is return Skip; end if; + -- Skip calls placed in unexpanded initialization expressions + + when N_Object_Declaration => + if No_Initialization (Nod) then + return Skip; + end if; + -- Skip calls placed in subprogram specifications since function -- calls initializing default parameter values will be processed -- when the call to the subprogram is found (if the default actual diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 67af1d7..905094c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2783,16 +2783,31 @@ package body Exp_Ch7 is Master_Node_Id := Make_Defining_Identifier (Master_Node_Loc, Chars => New_External_Name (Chars (Obj_Id), Suffix => "MN")); + Master_Node_Decl := Make_Master_Node_Declaration (Master_Node_Loc, Master_Node_Id, Obj_Id); Push_Scope (Scope (Obj_Id)); + + -- Avoid generating duplicate names for master nodes + + if Ekind (Obj_Id) = E_Loop_Parameter + and then + Present (Current_Entity_In_Scope (Chars (Master_Node_Id))) + then + Set_Chars (Master_Node_Id, + New_External_Name (Chars (Obj_Id), + Suffix => "MN", + Suffix_Index => -1)); + end if; + if not Has_Strict_Ctrl_Objs or else Count = 1 then Prepend_To (Decls, Master_Node_Decl); else Insert_Before (Decl, Master_Node_Decl); end if; + Analyze (Master_Node_Decl); Pop_Scope; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d75fd3a..9cfc6b5 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4273,6 +4273,7 @@ package body Exp_Ch9 is Defining_Identifier => Obj, Object_Definition => New_Occurrence_Of (Conctyp, Loc), Expression => ExpR); + Mutate_Ekind (Obj, E_Variable); Set_Etype (Obj, Conctyp); Decls := New_List (Decl); Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); @@ -5747,7 +5748,7 @@ package body Exp_Ch9 is Insert_Before_And_Analyze (N, Decl1); -- Associate the access to subprogram with its original access to - -- protected subprogram type. Needed by the backend to know that this + -- protected subprogram type. Needed by CodePeer to know that this -- type corresponds with an access to protected subprogram type. Set_Original_Access_Type (D_T2, T); @@ -9877,7 +9878,7 @@ package body Exp_Ch9 is -- (T => To_Tag_Ptr (Obj'Address).all, -- Position => -- Ada.Tags.Get_Offset_Index - -- (Ada.Tags.Tag (Concval), + -- (Concval._Tag, -- <interface dispatch table position of Ename>)); -- Note that Obj'Address is recursively expanded into a call to @@ -9898,7 +9899,9 @@ package body Exp_Ch9 is Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), Concval), + Make_Attribute_Reference (Loc, + Prefix => Concval, + Attribute_Name => Name_Tag), Make_Integer_Literal (Loc, DT_Position (Entity (Ename)))))))); @@ -10593,14 +10596,6 @@ package body Exp_Ch9 is Build_Accept_Body (Accept_Statement (Alt))); Reset_Scopes_To (Proc_Body, PB_Ent); - - -- During the analysis of the body of the accept statement, any - -- zero cost exception handler records were collected in the - -- Accept_Handler_Records field of the N_Accept_Alternative node. - -- This is where we move them to where they belong, namely the - -- newly created procedure. - - Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); Append (Proc_Body, Body_List); else diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 694fbe4..a351b9b 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -10980,6 +10980,7 @@ package body Exp_Dist is if not Constrained or else Depth > 1 then Inner_Any := Make_Defining_Identifier (Loc, New_External_Name ('A', Depth)); + Mutate_Ekind (Inner_Any, E_Variable); Set_Etype (Inner_Any, RTE (RE_Any)); else Inner_Any := Empty; @@ -10988,6 +10989,7 @@ package body Exp_Dist is if Present (Counter) then Inner_Counter := Make_Defining_Identifier (Loc, New_External_Name ('J', Depth)); + Mutate_Ekind (Inner_Counter, E_Variable); else Inner_Counter := Empty; end if; diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 03c7ca8..8759099 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -570,12 +570,16 @@ package body Exp_Fixd is -- Case where we can compute the denominator in Max_Integer_Size bits if QR_Id = RE_Null then + Mutate_Ekind (Qnn, E_Constant); + Mutate_Ekind (Rnn, E_Constant); -- Create temporaries for numerator and denominator and set Etypes, -- so that New_Occurrence_Of picks them up for Build_xxx calls. Nnn := Make_Temporary (Loc, 'N'); + Mutate_Ekind (Nnn, E_Constant); Dnn := Make_Temporary (Loc, 'D'); + Mutate_Ekind (Dnn, E_Constant); Set_Etype (Nnn, QR_Typ); Set_Etype (Dnn, QR_Typ); @@ -621,6 +625,8 @@ package body Exp_Fixd is -- to call the runtime routine to compute the quotient and remainder. else + Mutate_Ekind (Qnn, E_Variable); + Mutate_Ekind (Rnn, E_Variable); Rnd := Boolean_Literals (Rounded_Result_Set (N)); Code := New_List ( @@ -935,8 +941,13 @@ package body Exp_Fixd is -- Case where we can compute the numerator in Max_Integer_Size bits if QR_Id = RE_Null then + Mutate_Ekind (Qnn, E_Constant); + Mutate_Ekind (Rnn, E_Constant); + Nnn := Make_Temporary (Loc, 'N'); + Mutate_Ekind (Nnn, E_Constant); Dnn := Make_Temporary (Loc, 'D'); + Mutate_Ekind (Dnn, E_Constant); -- Set Etypes, so that they can be picked up by New_Occurrence_Of @@ -982,6 +993,9 @@ package body Exp_Fixd is -- to call the runtime routine to compute the quotient and remainder. else + Mutate_Ekind (Qnn, E_Variable); + Mutate_Ekind (Rnn, E_Variable); + Rnd := Boolean_Literals (Rounded_Result_Set (N)); Code := New_List ( diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 4eb93c3..f04016f 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -904,7 +904,8 @@ package body Exp_Pakd is -- discriminants, so we treat it as a default/per-object expression. Set_Parent (Len_Expr, Typ); - Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer); + Preanalyze_And_Resolve_Spec_Expression + (Len_Expr, Standard_Long_Long_Integer); -- Use a modular type if possible. We can do this if we have -- static bounds, and the length is small enough, and the length @@ -1525,21 +1526,24 @@ package body Exp_Pakd is Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); + Offset := Unchecked_Convert_To (RTE (RE_Storage_Offset), Offset); + Rewrite (N, - Unchecked_Convert_To (RTE (RE_Address), - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To (RTE (RE_Integer_Address), - Make_Attribute_Reference (Loc, - Prefix => Base, - Attribute_Name => Name_Address)), - - Right_Opnd => - Unchecked_Convert_To (RTE (RE_Integer_Address), - Make_Op_Divide (Loc, - Left_Opnd => Offset, - Right_Opnd => - Make_Integer_Literal (Loc, System_Storage_Unit)))))); + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Add, + Prefix => + New_Occurrence_Of (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, Name_Op_Add)), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Base, + Attribute_Name => Name_Address), + Make_Op_Divide (Loc, + Left_Opnd => Offset, + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit))))); Analyze_And_Resolve (N, RTE (RE_Address)); end Expand_Packed_Address_Reference; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index cc59620..340f2dc 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -3083,6 +3083,16 @@ package body Exp_Prag is end Expand_Pragma_Loop_Variant; -------------------------------- + -- Expand_Pragma_Program_Exit -- + -------------------------------- + + procedure Expand_Pragma_Program_Exit (Prag : Node_Id) is + pragma Unreferenced (Prag); + begin + null; + end Expand_Pragma_Program_Exit; + + -------------------------------- -- Expand_Pragma_Psect_Object -- -------------------------------- diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads index 036d7b1..cd78dd206 100644 --- a/gcc/ada/exp_prag.ads +++ b/gcc/ada/exp_prag.ads @@ -72,4 +72,8 @@ package Exp_Prag is -- of Prag is replaced with a reference to procedure with checks for the -- variant expressions. + procedure Expand_Pragma_Program_Exit (Prag : Node_Id); + -- This routine only exists for consistency with other pragmas, since + -- Program_Exit has no meaningful expansion. + end Exp_Prag; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b8c6a9f..028ee01 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1081,10 +1081,12 @@ package body Exp_Util is Make_Attribute_Reference (Loc, Prefix => (if Is_Allocate then - Duplicate_Subexpr_No_Checks (Expression (Alloc_Expr)) + Duplicate_Subexpr_No_Checks + (Expression (Alloc_Expr), New_Scope => Proc_Id) else Make_Explicit_Dereference (Loc, - Duplicate_Subexpr_No_Checks (Expr))), + Duplicate_Subexpr_No_Checks + (Expr, New_Scope => Proc_Id))), Attribute_Name => Name_Alignment))); end if; @@ -1137,7 +1139,9 @@ package body Exp_Util is if Is_RTE (Etype (Temp), RE_Tag_Ptr) then Param := Make_Explicit_Dereference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Temp)); + Prefix => + Duplicate_Subexpr_No_Checks + (Temp, New_Scope => Proc_Id)); -- In the default case, obtain the tag of the object about -- to be allocated / deallocated. Generate: @@ -1157,7 +1161,9 @@ package body Exp_Util is Param := Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Temp), + Prefix => + Duplicate_Subexpr_No_Checks + (Temp, New_Scope => Proc_Id), Attribute_Name => Name_Tag); end if; @@ -1956,7 +1962,7 @@ package body Exp_Util is -- time capture the visibility of the proper package part. Set_Parent (Expr, Typ_Decl); - Preanalyze_Assert_Expression (Expr, Any_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean); -- Save a copy of the expression with all replacements and analysis -- already taken place in case a derived type inherits the pragma. @@ -1969,8 +1975,8 @@ package body Exp_Util is -- If the pragma comes from an aspect specification, replace the -- saved expression because all type references must be substituted - -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx - -- routines. + -- for the call to Preanalyze_And_Resolve_Spec_Expression in + -- Check_Aspect_At_xxx routines. if Present (DIC_Asp) then Set_Expression_Copy (DIC_Asp, New_Copy_Tree (Expr)); @@ -3217,7 +3223,7 @@ package body Exp_Util is -- part. Set_Parent (Expr, Parent (Prag_Expr)); - Preanalyze_Assert_Expression (Expr, Any_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean); -- Save a copy of the expression when T is tagged to detect -- errors and capture the visibility of the proper package part @@ -3229,8 +3235,8 @@ package body Exp_Util is -- If the pragma comes from an aspect specification, replace -- the saved expression because all type references must be - -- substituted for the call to Preanalyze_Spec_Expression in - -- Check_Aspect_At_xxx routines. + -- substituted for the call to Preanalyze_And_Resolve_Spec_ + -- Expression in Check_Aspect_At_xxx routines. if Present (Prag_Asp) then Set_Expression_Copy (Prag_Asp, New_Copy_Tree (Expr)); @@ -5062,12 +5068,13 @@ package body Exp_Util is function Duplicate_Subexpr (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is begin Remove_Side_Effects (Exp, Name_Req, Renaming_Req); - return New_Copy_Tree (Exp); + return New_Copy_Tree (Exp, New_Scope => New_Scope); end Duplicate_Subexpr; --------------------------------- @@ -5076,8 +5083,9 @@ package body Exp_Util is function Duplicate_Subexpr_No_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; @@ -5087,7 +5095,7 @@ package body Exp_Util is Name_Req => Name_Req, Renaming_Req => Renaming_Req); - New_Exp := New_Copy_Tree (Exp); + New_Exp := New_Copy_Tree (Exp, New_Scope => New_Scope); Remove_Checks (New_Exp); return New_Exp; end Duplicate_Subexpr_No_Checks; @@ -5098,14 +5106,15 @@ package body Exp_Util is function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; begin Remove_Side_Effects (Exp, Name_Req, Renaming_Req); - New_Exp := New_Copy_Tree (Exp); + New_Exp := New_Copy_Tree (Exp, New_Scope => New_Scope); Remove_Checks (Exp); return New_Exp; end Duplicate_Subexpr_Move_Checks; @@ -10871,11 +10880,10 @@ package body Exp_Util is -- operator on private type might not be visible and won't be -- resolved. - else pragma Assert (Is_RTE (Base_Type (Typ), RE_Big_Integer) - or else - Is_RTE (Base_Type (Typ), RO_GH_Big_Integer) - or else - Is_RTE (Base_Type (Typ), RO_SP_Big_Integer)); + else + pragma Assert + (Is_RTE (Base_Type (Typ), RE_Big_Integer) + or else Is_RTE (Base_Type (Typ), RO_SP_Big_Integer)); return Make_Function_Call (Loc, Name => @@ -14466,7 +14474,16 @@ package body Exp_Util is else N := First (L); while Present (N) loop - if not Side_Effect_Free (N, Name_Req, Variable_Ref) then + if Nkind (N) = N_Parameter_Association then + if not + Side_Effect_Free + (Explicit_Actual_Parameter (N), Name_Req, Variable_Ref) + then + return False; + end if; + + Next (N); + elsif not Side_Effect_Free (N, Name_Req, Variable_Ref) then return False; else Next (N); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 6178767..1306f5e 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -479,8 +479,9 @@ package Exp_Util is function Duplicate_Subexpr (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Given the node for a subexpression, this function makes a logical copy -- of the subexpression, and returns it. This is intended for use when the -- expansion of an expression needs to repeat part of it. For example, @@ -494,6 +495,9 @@ package Exp_Util is -- the caller is responsible for analyzing the returned copy after it is -- attached to the tree. -- + -- The New_Scope entity may be used to specify a new scope for all copied + -- entities and itypes. + -- -- The Name_Req flag is set to ensure that the result is suitable for use -- in a context requiring a name (for example, the prefix of an attribute -- reference). @@ -509,8 +513,9 @@ package Exp_Util is function Duplicate_Subexpr_No_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on the result, so that the duplicated expression does not include -- checks. This is appropriate for use when Exp, the original expression is @@ -519,8 +524,9 @@ package Exp_Util is function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on Exp after the duplication is complete, so that the original -- expression does not include checks. In this case the result returned diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index bb8b96e..0b80a56 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -110,8 +110,8 @@ extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char); /* errout: */ -#define Error_Msg_N errout__error_msg_n -#define Error_Msg_NE errout__error_msg_ne +#define Error_Msg_N errout__error_msg_n_gigi +#define Error_Msg_NE errout__error_msg_ne_gigi #define Set_Identifier_Casing errout__set_identifier_casing extern void Error_Msg_N (String_Pointer, Node_Id); diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 39a09c4..ec22ad7 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -90,8 +90,9 @@ package body Fname.UF is Table_Initial => 10, Table_Increment => 100, Table_Name => "SFN_Patterns"); - -- Table recording calls to Set_File_Name_Pattern. Note that the first two - -- entries are set to represent the standard GNAT rules for file naming. + -- Table recording calls to Set_File_Name_Pattern. Note that the last two + -- entries are set to represent the standard GNAT rules for file naming; + -- that invariant is maintained by Set_File_Name_Pattern. procedure Instantiate_SFN_Pattern (Pattern : SFN_Pattern_Entry; @@ -178,6 +179,8 @@ package body Fname.UF is --------------------------- function Get_Default_File_Name (Uname : Unit_Name_Type) return String is + L : constant Int := SFN_Patterns.Last; + Buf : Bounded_String; Pattern : SFN_Pattern_Entry; @@ -185,10 +188,10 @@ package body Fname.UF is Get_Unit_Name_String (Buf, Uname, False); if Is_Spec_Name (Uname) then - Pattern := SFN_Patterns.Table (1); + Pattern := SFN_Patterns.Table (L - 1); else pragma Assert (Is_Body_Name (Uname)); - Pattern := SFN_Patterns.Table (2); + Pattern := SFN_Patterns.Table (L); end if; Instantiate_SFN_Pattern (Pattern, Buf); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 54b6202..ec0fb16e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -9389,16 +9389,17 @@ package body Freeze is -- pre/postconditions during expansion of the subprogram body, the -- subprogram is already installed. - -- Call Preanalyze_Spec_Expression instead of Preanalyze_And_Resolve - -- for the sake of consistency with Analyze_Expression_Function. + -- Call Preanalyze_And_Resolve_Spec_Expression instead of Preanalyze_ + -- And_Resolve for the sake of consistency with Analyze_Expression_ + -- Function. if Def_Id /= Current_Scope then Push_Scope (Def_Id); Install_Formals (Def_Id); - Preanalyze_Spec_Expression (Dup_Expr, Typ); + Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ); End_Scope; else - Preanalyze_Spec_Expression (Dup_Expr, Typ); + Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ); end if; -- Restore certain attributes of Def_Id since the preanalysis may diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 2158bb6..54496ea 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -315,23 +315,17 @@ GNAT_ADA_OBJS = \ ada/cstand.o \ ada/debug.o \ ada/debug_a.o \ - ada/diagnostics-brief_emitter.o \ - ada/diagnostics-constructors.o \ - ada/diagnostics-converter.o \ - ada/diagnostics-json_utils.o \ - ada/diagnostics-pretty_emitter.o \ - ada/diagnostics-repository.o \ - ada/diagnostics-sarif_emitter.o \ - ada/diagnostics-switch_repository.o \ - ada/diagnostics-utils.o \ - ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ ada/elists.o \ ada/err_vars.o \ + ada/errid.o \ ada/errout.o \ ada/erroutc.o \ + ada/erroutc-pretty_emitter.o \ + ada/erroutc-sarif_emitter.o \ + ada/errsw.o \ ada/eval_fat.o \ ada/exp_aggr.o \ ada/exp_spark.o \ @@ -380,6 +374,7 @@ GNAT_ADA_OBJS = \ ada/impunit.o \ ada/inline.o \ ada/itypes.o \ + ada/json_utils.o \ ada/krunch.o \ ada/layout.o \ ada/lib-load.o \ @@ -562,8 +557,6 @@ GNAT_ADA_OBJS+= \ ada/libgnat/s-secsta.o \ ada/libgnat/s-soflin.o \ ada/libgnat/s-soliin.o \ - ada/libgnat/s-spark.o \ - ada/libgnat/s-spcuop.o \ ada/libgnat/s-stache.o \ ada/libgnat/s-stalib.o \ ada/libgnat/s-stoele.o \ @@ -575,11 +568,8 @@ GNAT_ADA_OBJS+= \ ada/libgnat/s-trasym.o \ ada/libgnat/s-unstyp.o \ ada/libgnat/s-valint.o \ - ada/libgnat/s-valspe.o \ ada/libgnat/s-valuns.o \ ada/libgnat/s-valuti.o \ - ada/libgnat/s-vs_int.o \ - ada/libgnat/s-vs_uns.o \ ada/libgnat/s-wchcnv.o \ ada/libgnat/s-wchcon.o \ ada/libgnat/s-wchjis.o \ @@ -615,23 +605,17 @@ GNATBIND_OBJS = \ ada/casing.o \ ada/csets.o \ ada/debug.o \ - ada/diagnostics-brief_emitter.o \ - ada/diagnostics-constructors.o \ - ada/diagnostics-converter.o \ - ada/diagnostics-json_utils.o \ - ada/diagnostics-pretty_emitter.o \ - ada/diagnostics-repository.o \ - ada/diagnostics-sarif_emitter.o \ - ada/diagnostics-switch_repository.o \ - ada/diagnostics-utils.o \ - ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ ada/elists.o \ ada/err_vars.o \ + ada/errid.o \ ada/errout.o \ ada/erroutc.o \ + ada/erroutc-sarif_emitter.o \ + ada/erroutc-pretty_emitter.o \ + ada/errsw.o \ ada/exit.o \ ada/final.o \ ada/fmap.o \ @@ -639,6 +623,7 @@ GNATBIND_OBJS = \ ada/gnatbind.o \ ada/gnatvsn.o \ ada/hostparm.o \ + ada/json_utils.o \ ada/lib.o \ ada/link.o \ ada/namet.o \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 2c42cb1..a8777e1 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -328,16 +328,11 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \ uname.o urealp.o usage.o widechar.o warnsw.o \ seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \ - diagnostics-brief_emitter.o \ - diagnostics-constructors.o \ - diagnostics-converter.o \ - diagnostics-json_utils.o \ - diagnostics-pretty_emitter.o \ - diagnostics-repository.o \ - diagnostics-sarif_emitter.o \ - diagnostics-switch_repository.o \ - diagnostics-utils.o \ - diagnostics.o \ + errid.o \ + errsw.o \ + erroutc-pretty_emitter.o \ + erroutc-sarif_emitter.o \ + json_utils.o $(EXTRA_GNATMAKE_OBJS) # Make arch match the current multilib so that the RTS selection code diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index c293e0f..9871035 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -56,7 +56,6 @@ package Gen_IL.Fields is Abort_Present, Abortable_Part, Abstract_Present, - Accept_Handler_Records, Accept_Statement, Access_Definition, Access_To_Subprogram_Definition, @@ -230,7 +229,6 @@ package Gen_IL.Fields is Import_Interface_Present, In_Present, Includes_Infinities, - Incomplete_View, Inherited_Discriminant, Instance_Spec, Intval, @@ -256,6 +254,7 @@ package Gen_IL.Fields is Is_Elsif, Is_Entry_Barrier_Function, Is_Expanded_Build_In_Place_Call, + Is_Expanded_Constructor_Call, Is_Expanded_Prefixed_Call, Is_Folded_In_Parser, Is_Generic_Contract_Pragma, @@ -472,6 +471,8 @@ package Gen_IL.Fields is Component_Clause, Component_Size, Component_Type, + Constructor_List, + Constructor_Name, Contract, Contract_Wrapper, Corresponding_Concurrent_Type, @@ -487,12 +488,10 @@ package Gen_IL.Fields is Debug_Renaming_Link, Default_Aspect_Component_Value, Default_Aspect_Value, - Default_Expr_Function, Default_Expressions_Processed, Default_Value, Delay_Cleanups, Delta_Value, - Dependent_Instances, Depends_On_Private, Derived_Type_Link, Digits_Value, @@ -553,7 +552,6 @@ package Gen_IL.Fields is Full_View, Generic_Homonym, Generic_Renamings, - Handler_Records, Has_Aliased_Components, Has_Alignment_Clause, Has_All_Calls_Remote, @@ -659,6 +657,7 @@ package Gen_IL.Fields is Ignore_SPARK_Mode_Pragmas, Import_Pragma, Incomplete_Actuals, + Incomplete_View, Indirect_Call_Wrapper, In_Package_Body, In_Private_Part, @@ -744,6 +743,7 @@ package Gen_IL.Fields is Is_Known_Non_Null, Is_Known_Null, Is_Known_Valid, + Is_Large_Unconstrained_Definite, Is_Limited_Composite, Is_Limited_Interface, Is_Limited_Record, @@ -822,7 +822,7 @@ package Gen_IL.Fields is Modulus, Must_Be_On_Byte_Boundary, Must_Have_Preelab_Init, - Needs_Activation_Record, + Needs_Construction, Needs_Debug_Info, Needs_No_Actuals, Never_Set_In_Source, @@ -870,7 +870,6 @@ package Gen_IL.Fields is Referenced_As_LHS, Referenced_As_Out_Parameter, Refinement_Constituents, - Register_Exception_Call, Related_Array_Object, Related_Expression, Related_Instance, @@ -892,7 +891,6 @@ package Gen_IL.Fields is Scope_Depth_Value, Sec_Stack_Needed_For_Return, Shared_Var_Procs_Instance, - Size_Check_Code, Size_Depends_On_Discriminant, Size_Known_At_Compile_Time, Small_Value, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 37ddd85..bfa634f 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -114,6 +114,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Has_Xref_Entry, Flag), Sm (Has_Yield_Aspect, Flag), Sm (Homonym, Node_Id), + Sm (Incomplete_View, Node_Id), Sm (In_Package_Body, Flag), Sm (In_Private_Part, Flag), Sm (In_Use, Flag), @@ -212,7 +213,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Low_Bound_Tested, Flag), Sm (Materialize_Entity, Flag), Sm (May_Inherit_Delayed_Rep_Aspects, Flag), - Sm (Needs_Activation_Record, Flag), Sm (Needs_Debug_Info, Flag), Sm (Never_Set_In_Source, Flag), Sm (Overlays_Constant, Flag), @@ -288,7 +288,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Extra_Formal, Node_Id), Sm (Generic_Homonym, Node_Id), Sm (Generic_Renamings, Elist_Id), - Sm (Handler_Records, List_Id), Sm (Has_Static_Discriminants, Flag), Sm (Inner_Instances, Elist_Id), Sm (Interface_Name, Node_Id), @@ -357,7 +356,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Prival_Link, Node_Id), Sm (Related_Type, Node_Id), Sm (Return_Statement, Node_Id), - Sm (Size_Check_Code, Node_Id), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); @@ -399,7 +397,6 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Activation_Record_Component, Node_Id), Sm (Actual_Subtype, Node_Id), Sm (Alignment, Unat), - Sm (Default_Expr_Function, Node_Id), Sm (Default_Value, Node_Id), Sm (Entry_Component, Node_Id), Sm (Extra_Accessibility, Node_Id), @@ -458,6 +455,8 @@ begin -- Gen_IL.Gen.Gen_Entities Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"), Sm (Class_Wide_Equivalent_Type, Node_Id), Sm (Class_Wide_Type, Node_Id), + Sm (Constructor_List, Elist_Id), + Sm (Constructor_Name, Node_Id), Sm (Contract, Node_Id), Sm (Current_Use_Clause, Node_Id), Sm (Derived_Type_Link, Node_Id), @@ -516,6 +515,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Linker_Section_Pragma, Node_Id), Sm (Must_Be_On_Byte_Boundary, Flag), Sm (Must_Have_Preelab_Init, Flag), + Sm (Needs_Construction, Flag), Sm (No_Tagged_Streams_Pragma, Node_Id, Pre => "Is_Tagged_Type (N)"), Sm (Non_Binary_Modulus, Flag, Base_Type_Only), @@ -576,7 +576,7 @@ begin -- Gen_IL.Gen.Gen_Entities -- created for the base type, and this is the first named subtype). Ab (Modular_Integer_Kind, Integer_Kind, - (Sm (Modulus, Uint, Base_Type_Only), + (Sm (Modulus, Uint, Impl_Base_Type_Only), Sm (Original_Array_Type, Node_Id))); Cc (E_Modular_Integer_Type, Modular_Integer_Kind); @@ -781,7 +781,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (No_Reordering, Flag, Impl_Base_Type_Only), Sm (Parent_Subtype, Node_Id, Base_Type_Only), Sm (Reverse_Bit_Order, Flag, Base_Type_Only), - Sm (Underlying_Record_View, Node_Id))); + Sm (Underlying_Record_View, Node_Id), + Sm (Is_Large_Unconstrained_Definite, Flag, Impl_Base_Type_Only))); Cc (E_Record_Subtype, Aggregate_Kind, -- A record subtype, created by a record subtype declaration @@ -1004,7 +1005,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (DTC_Entity, Node_Id), Sm (Extra_Accessibility_Of_Result, Node_Id), Sm (Generic_Renamings, Elist_Id), - Sm (Handler_Records, List_Id), Sm (Has_Missing_Return, Flag), Sm (Inner_Instances, Elist_Id), Sm (Is_Called, Flag), @@ -1048,7 +1048,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (DTC_Entity, Node_Id), Sm (Entry_Parameters_Type, Node_Id), Sm (Generic_Renamings, Elist_Id), - Sm (Handler_Records, List_Id), Sm (Inner_Instances, Elist_Id), Sm (Is_Asynchronous, Flag), Sm (Is_Called, Flag), @@ -1167,7 +1166,6 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Alignment, Unat), Sm (Interface_Name, Node_Id), Sm (Is_Raised, Flag), - Sm (Register_Exception_Call, Node_Id), Sm (Renamed_Or_Alias, Node_Id))); Ab (Generic_Unit_Kind, Entity_Kind, @@ -1256,8 +1254,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Body_Needed_For_SAL, Flag), Sm (Contract, Node_Id), Sm (Current_Use_Clause, Node_Id), - Sm (Dependent_Instances, Elist_Id, - Pre => "Is_Generic_Instance (N)"), Sm (Elaborate_Body_Desirable, Flag), Sm (Elaboration_Entity, Node_Id), Sm (Elaboration_Entity_Required, Flag), @@ -1265,7 +1261,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (First_Entity, Node_Id), Sm (First_Private_Entity, Node_Id), Sm (Generic_Renamings, Elist_Id), - Sm (Handler_Records, List_Id), Sm (Has_RACW, Flag), Sm (Hidden_In_Formal_Instance, Elist_Id), Sm (Ignore_SPARK_Mode_Pragmas, Flag), @@ -1297,7 +1292,6 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Contract, Node_Id), Sm (Finalizer, Node_Id), Sm (First_Entity, Node_Id), - Sm (Handler_Records, List_Id), Sm (Ignore_SPARK_Mode_Pragmas, Flag), Sm (Last_Entity, Node_Id), Sm (Related_Instance, Node_Id), diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index eb03536..e50a488 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -303,6 +303,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Is_Known_Guaranteed_ABE, Flag), Sm (Is_SPARK_Mode_On_Node, Flag), Sm (No_Elaboration_Check, Flag), + Sm (Is_Expanded_Constructor_Call, Flag), Sm (Is_Expanded_Prefixed_Call, Flag))); Cc (N_Function_Call, N_Subprogram_Call, @@ -533,8 +534,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Discriminant_Specifications, List_Id, Default_No_List), Sy (Type_Definition, Node_Id), Sy (Aspect_Specifications, List_Id, Default_No_List), - Sm (Discr_Check_Funcs_Built, Flag), - Sm (Incomplete_View, Node_Id))); + Sm (Discr_Check_Funcs_Built, Flag))); Cc (N_Incomplete_Type_Declaration, N_Declaration, (Sy (Defining_Identifier, Node_Id), @@ -1030,8 +1030,7 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Accept_Statement, Node_Id), Sy (Condition, Node_Id, Default_Empty), Sy (Statements, List_Id, Default_Empty_List), - Sy (Pragmas_Before, List_Id, Default_No_List), - Sm (Accept_Handler_Records, List_Id))); + Sy (Pragmas_Before, List_Id, Default_No_List))); Cc (N_Delay_Alternative, Node_Kind, (Sy (Delay_Statement, Node_Id), diff --git a/gcc/ada/generate_minimal_reproducer.adb b/gcc/ada/generate_minimal_reproducer.adb index 66d34fe..5a5ae16 100644 --- a/gcc/ada/generate_minimal_reproducer.adb +++ b/gcc/ada/generate_minimal_reproducer.adb @@ -23,16 +23,18 @@ -- -- ------------------------------------------------------------------------------ +with Atree; with Fmap; with Fname.UF; with Lib; -with Namet; use Namet; -with Osint; use Osint; -with Output; use Output; -with Sinfo.Nodes; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Sinfo.Nodes; use Sinfo.Nodes; with System.CRTL; with System.OS_Lib; use System.OS_Lib; -with Types; use Types; +with Types; use Types; +with Uname; procedure Generate_Minimal_Reproducer is Reproducer_Generation_Failed : exception; @@ -85,6 +87,26 @@ procedure Generate_Minimal_Reproducer is Oracle_Path : constant String := Dirname & Directory_Separator & Executable_Name ("oracle"); + Main_Library_Item : constant Node_Id := Unit (Lib.Cunit (Main_Unit)); + + -- There is a special case that we need to detect: when the main library + -- item is the instantiation of a generic that has a body, and the + -- instantiation of generic bodies has started. We start by binding whether + -- the main library item is an instantiation to the following constant. + Main_Is_Instantiation : constant Boolean := + Nkind (Atree.Original_Node (Main_Library_Item)) + in N_Generic_Instantiation; + + -- If the main library item is an instantiation and its unit name is a body + -- name, it means that Make_Instance_Unit has been called. We need to use + -- the corresponding spec name to reconstruct the on-disk form of the + -- semantic closure. + Main_Unit_Name : constant Unit_Name_Type := + (if Main_Is_Instantiation + and then Uname.Is_Body_Name (Lib.Unit_Name (Main_Unit)) + then Uname.Get_Spec_Name (Lib.Unit_Name (Main_Unit)) + else Lib.Unit_Name (Main_Unit)); + Result : Integer; begin Create_Semantic_Closure_Project : @@ -118,25 +140,30 @@ begin end if; for J in Main_Unit .. Lib.Last_Unit loop - declare - Path : File_Name_Type := - Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J)); - - Default_File_Name : constant String := - Fname.UF.Get_Default_File_Name (Lib.Unit_Name (J)); - - File_Copy_Path : constant String := - Src_Dir_Path & Directory_Separator & Default_File_Name; - - -- We may have synthesized units for child subprograms without - -- spec files. We need to filter out those units because we would - -- create bogus spec files that break compilation if we didn't. - Is_Synthetic_Subprogram_Spec : constant Boolean := - not Sinfo.Nodes.Comes_From_Source (Lib.Cunit (J)); - begin - if not Lib.Is_Internal_Unit (J) - and then not Is_Synthetic_Subprogram_Spec - then + -- We skip library units that fall under one of the following cases: + -- - Internal library units. + -- - Units that were synthesized for child subprograms without spec + -- files. + -- - Dummy entries that Add_Preprocessing_Dependency puts in + -- Lib.Units. + -- Those cases correspond to the conjuncts in the condition below. + if not Lib.Is_Internal_Unit (J) + and then Comes_From_Source (Lib.Cunit (J)) + and then Lib.Unit_Name (J) /= No_Unit_Name + then + declare + Path : File_Name_Type := + Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J)); + + Unit_Name : constant Unit_Name_Type := + (if J = Main_Unit then Main_Unit_Name else Lib.Unit_Name (J)); + + Default_File_Name : constant String := + Fname.UF.Get_Default_File_Name (Unit_Name); + + File_Copy_Path : constant String := + Src_Dir_Path & Directory_Separator & Default_File_Name; + begin -- Mapped_Path_Name might have returned No_File. This has been -- observed for files with a Source_File_Name pragma. if Path = No_File then @@ -153,8 +180,8 @@ begin pragma Assert (Success); end; - end if; - end; + end; + end if; end loop; end Create_Semantic_Closure_Project; @@ -197,7 +224,7 @@ begin (Fmap.Mapped_Path_Name (Lib.Unit_File_Name (Main_Unit))); Default_Main_Name : constant String := - Fname.UF.Get_Default_File_Name (Lib.Unit_Name (Main_Unit)); + Fname.UF.Get_Default_File_Name (Main_Unit_Name); New_Main_Path : constant String := Src_Dir_Path & Directory_Separator & Default_Main_Name; @@ -228,7 +255,8 @@ begin Write_Eol; Write_Line (" Args : constant GNAT.OS_Lib.Argument_List :="); - Write_Str (" (new String'(""-gnatd_M"")"); + Write_Str + (" (new String'(""-quiet""), new String'(""-gnatd_M"")"); -- The following way of iterating through the command line arguments -- was copied from Set_Targ. TODO factorize??? diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads index 35cf00d..4b658f1 100644 --- a/gcc/ada/get_targ.ads +++ b/gcc/ada/get_targ.ads @@ -113,7 +113,7 @@ package Get_Targ is type C_String is array (0 .. 255) of aliased Character; pragma Convention (C, C_String); - type Register_Type_Proc is access procedure + type Register_Type_Proc is not null access procedure (C_Name : C_String; -- Nul-terminated string with name of type Digs : Natural; -- Digits for floating point, 0 otherwise Complex : Boolean; -- True iff type has real and imaginary parts diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi index dde6ec4..0880400 100644 --- a/gcc/ada/gnat-style.texi +++ b/gcc/ada/gnat-style.texi @@ -3,7 +3,7 @@ @setfilename gnat-style.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 8.0.2.@* +@*Generated by Sphinx 8.2.3.@* @end ifinfo @settitle GNAT Coding Style A Guide for GNAT Developers @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT Coding Style: A Guide for GNAT Developers , Jan 03, 2025 +GNAT Coding Style: A Guide for GNAT Developers , Jun 02, 2025 AdaCore diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 97469d7..4d98471 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3,7 +3,7 @@ @setfilename gnat_rm.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 8.0.2.@* +@*Generated by Sphinx 8.2.3.@* @end ifinfo @settitle GNAT Reference Manual @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Jan 03, 2025 +GNAT Reference Manual , Jun 02, 2025 AdaCore @@ -238,6 +238,7 @@ Implementation Defined Pragmas * Pragma Priority_Specific_Dispatching:: * Pragma Profile:: * Pragma Profile_Warnings:: +* Pragma Program_Exit:: * Pragma Propagate_Exceptions:: * Pragma Provide_Shift_Operators:: * Pragma Psect_Object:: @@ -348,6 +349,7 @@ Implementation Defined Aspects * Aspect Part_Of:: * Aspect Persistent_BSS:: * Aspect Predicate:: +* Aspect Program_Exit:: * Aspect Pure_Function:: * Aspect Refined_Depends:: * Aspect Refined_Global:: @@ -916,6 +918,7 @@ Deep delta Aggregates Experimental Language Extensions * Conditional when constructs:: +* Implicit With:: * Storage Model:: * Attribute Super:: * Simpler Accessibility Model:: @@ -1405,6 +1408,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Priority_Specific_Dispatching:: * Pragma Profile:: * Pragma Profile_Warnings:: +* Pragma Program_Exit:: * Pragma Propagate_Exceptions:: * Pragma Provide_Shift_Operators:: * Pragma Psect_Object:: @@ -3470,6 +3474,7 @@ EXIT_CASE ::= GUARD => EXIT_KIND EXIT_KIND ::= Normal_Return | Exception_Raised | (Exception_Raised => exception_name) + | Program_Exit GUARD ::= Boolean_expression @end example @@ -4682,8 +4687,8 @@ pragma Interrupt_State Normally certain interrupts are reserved to the implementation. Any attempt to attach an interrupt causes Program_Error to be raised, as described in RM C.3.2(22). A typical example is the @code{SIGINT} interrupt used in -many systems for an @code{Ctrl-C} interrupt. Normally this interrupt is -reserved to the implementation, so that @code{Ctrl-C} can be used to +many systems for an @code{Ctrl}-@code{C} interrupt. Normally this interrupt is +reserved to the implementation, so that @code{Ctrl}-@code{C} can be used to interrupt execution. Additionally, signals such as @code{SIGSEGV}, @code{SIGABRT}, @code{SIGFPE} and @code{SIGILL} are often mapped to specific Ada exceptions, or used to implement run-time functions such as the @@ -6912,7 +6917,7 @@ conforming Ada constructs. The profile enables the following three pragmas: @end itemize @end itemize -@node Pragma Profile_Warnings,Pragma Propagate_Exceptions,Pragma Profile,Implementation Defined Pragmas +@node Pragma Profile_Warnings,Pragma Program_Exit,Pragma Profile,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{ce} @section Pragma Profile_Warnings @@ -6930,8 +6935,22 @@ generating @code{Restrictions} pragmas, it generates violations of the profile generate warning messages instead of error messages. -@node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Profile_Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{cf} +@node Pragma Program_Exit,Pragma Propagate_Exceptions,Pragma Profile_Warnings,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{cf}@anchor{gnat_rm/implementation_defined_pragmas pragma-program-exit}@anchor{d0} +@section Pragma Program_Exit + + +Syntax: + +@example +pragma Program_Exit [ (boolean_EXPRESSION) ]; +@end example + +For the semantics of this pragma, see the entry for aspect @code{Program_Exit} +in the SPARK 2014 Reference Manual, section 6.1.10. + +@node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Program_Exit,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{d1} @section Pragma Propagate_Exceptions @@ -6950,7 +6969,7 @@ purposes. It used to be used in connection with optimization of a now-obsolete mechanism for implementation of exceptions. @node Pragma Provide_Shift_Operators,Pragma Psect_Object,Pragma Propagate_Exceptions,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{d0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{d2} @section Pragma Provide_Shift_Operators @@ -6970,7 +6989,7 @@ including the function declarations for these five operators, together with the pragma Import (Intrinsic, …) statements. @node Pragma Psect_Object,Pragma Pure_Function,Pragma Provide_Shift_Operators,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{d1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{d3} @section Pragma Psect_Object @@ -6990,7 +7009,7 @@ EXTERNAL_SYMBOL ::= This pragma is identical in effect to pragma @code{Common_Object}. @node Pragma Pure_Function,Pragma Rational,Pragma Psect_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d2}@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{d3} +@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d4}@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{d5} @section Pragma Pure_Function @@ -7052,7 +7071,7 @@ unit is not a Pure unit in the categorization sense. So for example, a function thus marked is free to @code{with} non-pure units. @node Pragma Rational,Pragma Ravenscar,Pragma Pure_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{d4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{d6} @section Pragma Rational @@ -7070,7 +7089,7 @@ pragma Profile (Rational); @end example @node Pragma Ravenscar,Pragma Refined_Depends,Pragma Rational,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{d5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{d7} @section Pragma Ravenscar @@ -7090,7 +7109,7 @@ pragma Profile (Ravenscar); which is the preferred method of setting the @code{Ravenscar} profile. @node Pragma Refined_Depends,Pragma Refined_Global,Pragma Ravenscar,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d6}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{d7} +@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{d9} @section Pragma Refined_Depends @@ -7123,7 +7142,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Depends the SPARK 2014 Reference Manual, section 6.1.5. @node Pragma Refined_Global,Pragma Refined_Post,Pragma Refined_Depends,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{d9} +@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{da}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{db} @section Pragma Refined_Global @@ -7148,7 +7167,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Global} the SPARK 2014 Reference Manual, section 6.1.4. @node Pragma Refined_Post,Pragma Refined_State,Pragma Refined_Global,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{da}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{db} +@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{dc}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{dd} @section Pragma Refined_Post @@ -7162,7 +7181,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Post} i the SPARK 2014 Reference Manual, section 7.2.7. @node Pragma Refined_State,Pragma Relative_Deadline,Pragma Refined_Post,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{dc}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{dd} +@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{de}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{df} @section Pragma Refined_State @@ -7188,7 +7207,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_State} the SPARK 2014 Reference Manual, section 7.2.2. @node Pragma Relative_Deadline,Pragma Remote_Access_Type,Pragma Refined_State,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{de} +@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{e0} @section Pragma Relative_Deadline @@ -7203,7 +7222,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Remote_Access_Type,Pragma Rename_Pragma,Pragma Relative_Deadline,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{df}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{e0} +@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e1}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{e2} @section Pragma Remote_Access_Type @@ -7229,7 +7248,7 @@ pertaining to remote access to class-wide types. At instantiation, the actual type must be a remote access to class-wide type. @node Pragma Rename_Pragma,Pragma Restricted_Run_Time,Pragma Remote_Access_Type,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{e1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{e3} @section Pragma Rename_Pragma @@ -7268,7 +7287,7 @@ Pragma Inline_Only will not necessarily mean the same thing as the other Ada compiler; it’s up to you to make sure the semantics are close enough. @node Pragma Restricted_Run_Time,Pragma Restriction_Warnings,Pragma Rename_Pragma,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{e2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{e4} @section Pragma Restricted_Run_Time @@ -7289,7 +7308,7 @@ which is the preferred method of setting the restricted run time profile. @node Pragma Restriction_Warnings,Pragma Reviewable,Pragma Restricted_Run_Time,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{e3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{e5} @section Pragma Restriction_Warnings @@ -7327,7 +7346,7 @@ generating a warning, but any other use of implementation defined pragmas will cause a warning to be generated. @node Pragma Reviewable,Pragma Secondary_Stack_Size,Pragma Restriction_Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{e4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{e6} @section Pragma Reviewable @@ -7431,7 +7450,7 @@ comprehensive messages identifying possible problems based on this information. @node Pragma Secondary_Stack_Size,Pragma Share_Generic,Pragma Reviewable,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e5}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{e6} +@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e7}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{e8} @section Pragma Secondary_Stack_Size @@ -7467,7 +7486,7 @@ Note the pragma cannot appear when the restriction @code{No_Secondary_Stack} is in effect. @node Pragma Share_Generic,Pragma Shared,Pragma Secondary_Stack_Size,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{e7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{e9} @section Pragma Share_Generic @@ -7485,7 +7504,7 @@ than to check that the given names are all names of generic units or generic instances. @node Pragma Shared,Pragma Short_Circuit_And_Or,Pragma Share_Generic,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e8}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e9} +@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ea}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{eb} @section Pragma Shared @@ -7493,7 +7512,7 @@ This pragma is provided for compatibility with Ada 83. The syntax and semantics are identical to pragma Atomic. @node Pragma Short_Circuit_And_Or,Pragma Short_Descriptors,Pragma Shared,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{ea} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{ec} @section Pragma Short_Circuit_And_Or @@ -7512,7 +7531,7 @@ within the file being compiled, it applies only to the file being compiled. There is no requirement that all units in a partition use this option. @node Pragma Short_Descriptors,Pragma Side_Effects,Pragma Short_Circuit_And_Or,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{eb} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{ed} @section Pragma Short_Descriptors @@ -7526,7 +7545,7 @@ This pragma is provided for compatibility with other Ada implementations. It is recognized but ignored by all current versions of GNAT. @node Pragma Side_Effects,Pragma Simple_Storage_Pool_Type,Pragma Short_Descriptors,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ec}@anchor{gnat_rm/implementation_defined_pragmas pragma-side-effects}@anchor{ed} +@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{ee}@anchor{gnat_rm/implementation_defined_pragmas pragma-side-effects}@anchor{ef} @section Pragma Side_Effects @@ -7540,7 +7559,7 @@ For the semantics of this pragma, see the entry for aspect @code{Side_Effects} in the SPARK Reference Manual, section 6.1.12. @node Pragma Simple_Storage_Pool_Type,Pragma Source_File_Name,Pragma Side_Effects,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{ee}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{ef} +@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f0}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{f1} @section Pragma Simple_Storage_Pool_Type @@ -7594,7 +7613,7 @@ storage-management discipline). An object of a simple storage pool type can be associated with an access type by specifying the attribute -@ref{f0,,Simple_Storage_Pool}. For example: +@ref{f2,,Simple_Storage_Pool}. For example: @example My_Pool : My_Simple_Storage_Pool_Type; @@ -7604,11 +7623,11 @@ type Acc is access My_Data_Type; for Acc'Simple_Storage_Pool use My_Pool; @end example -See attribute @ref{f0,,Simple_Storage_Pool} +See attribute @ref{f2,,Simple_Storage_Pool} for further details. @node Pragma Source_File_Name,Pragma Source_File_Name_Project,Pragma Simple_Storage_Pool_Type,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f1}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{f2} +@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{f3}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{f4} @section Pragma Source_File_Name @@ -7700,20 +7719,20 @@ aware of these pragmas, and so other tools that use the project file would not be aware of the intended naming conventions. If you are using project files, file naming is controlled by Source_File_Name_Project pragmas, which are usually supplied automatically by the project manager. A pragma -Source_File_Name cannot appear after a @ref{f3,,Pragma Source_File_Name_Project}. +Source_File_Name cannot appear after a @ref{f5,,Pragma Source_File_Name_Project}. For more details on the use of the @code{Source_File_Name} pragma, see the sections on @cite{Using Other File Names} and @cite{Alternative File Naming Schemes} in the @cite{GNAT User’s Guide}. @node Pragma Source_File_Name_Project,Pragma Source_Reference,Pragma Source_File_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{f4}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{f3} +@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{f6}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{f5} @section Pragma Source_File_Name_Project This pragma has the same syntax and semantics as pragma Source_File_Name. It is only allowed as a stand-alone configuration pragma. -It cannot appear after a @ref{f2,,Pragma Source_File_Name}, and +It cannot appear after a @ref{f4,,Pragma Source_File_Name}, and most importantly, once pragma Source_File_Name_Project appears, no further Source_File_Name pragmas are allowed. @@ -7725,7 +7744,7 @@ Source_File_Name or Source_File_Name_Project pragmas (which would not be known to the project manager). @node Pragma Source_Reference,Pragma SPARK_Mode,Pragma Source_File_Name_Project,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{f5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{f7} @section Pragma Source_Reference @@ -7749,7 +7768,7 @@ string expression other than a string literal. This is because its value is needed for error messages issued by all phases of the compiler. @node Pragma SPARK_Mode,Pragma Static_Elaboration_Desired,Pragma Source_Reference,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{f6}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{f7} +@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{f8}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{f9} @section Pragma SPARK_Mode @@ -7831,7 +7850,7 @@ SPARK_Mode (@code{Off}), then that pragma will need to be repeated in the package body. @node Pragma Static_Elaboration_Desired,Pragma Stream_Convert,Pragma SPARK_Mode,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{f8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{fa} @section Pragma Static_Elaboration_Desired @@ -7855,7 +7874,7 @@ construction of larger aggregates with static components that include an others choice.) @node Pragma Stream_Convert,Pragma Style_Checks,Pragma Static_Elaboration_Desired,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{f9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{fb} @section Pragma Stream_Convert @@ -7932,7 +7951,7 @@ the pragma is silently ignored, and the default implementation of the stream attributes is used instead. @node Pragma Style_Checks,Pragma Subprogram_Variant,Pragma Stream_Convert,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{fa} +@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{fc} @section Pragma Style_Checks @@ -8078,7 +8097,7 @@ Rf2 : Integer := ARG; -- OK, no error @end example @node Pragma Subprogram_Variant,Pragma Subtitle,Pragma Style_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-subprogram-variant}@anchor{fb} +@anchor{gnat_rm/implementation_defined_pragmas pragma-subprogram-variant}@anchor{fd} @section Pragma Subprogram_Variant @@ -8110,7 +8129,7 @@ the implementation-defined @code{Subprogram_Variant} aspect, and shares its restrictions and semantics. @node Pragma Subtitle,Pragma Suppress,Pragma Subprogram_Variant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{fc} +@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{fe} @section Pragma Subtitle @@ -8124,7 +8143,7 @@ This pragma is recognized for compatibility with other Ada compilers but is ignored by GNAT. @node Pragma Suppress,Pragma Suppress_All,Pragma Subtitle,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{fd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{ff} @section Pragma Suppress @@ -8197,7 +8216,7 @@ Of course, run-time checks are omitted whenever the compiler can prove that they will not fail, whether or not checks are suppressed. @node Pragma Suppress_All,Pragma Suppress_Debug_Info,Pragma Suppress,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{fe} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{100} @section Pragma Suppress_All @@ -8216,7 +8235,7 @@ The use of the standard Ada pragma @code{Suppress (All_Checks)} as a normal configuration pragma is the preferred usage in GNAT. @node Pragma Suppress_Debug_Info,Pragma Suppress_Exception_Locations,Pragma Suppress_All,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{ff}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{100} +@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{101}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{102} @section Pragma Suppress_Debug_Info @@ -8231,7 +8250,7 @@ for the specified entity. It is intended primarily for use in debugging the debugger, and navigating around debugger problems. @node Pragma Suppress_Exception_Locations,Pragma Suppress_Initialization,Pragma Suppress_Debug_Info,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{101} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{103} @section Pragma Suppress_Exception_Locations @@ -8254,7 +8273,7 @@ a partition, so it is fine to have some units within a partition compiled with this pragma and others compiled in normal mode without it. @node Pragma Suppress_Initialization,Pragma Task_Name,Pragma Suppress_Exception_Locations,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{102}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{103} +@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{104}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{105} @section Pragma Suppress_Initialization @@ -8299,7 +8318,7 @@ is suppressed, just as though its subtype had been given in a pragma Suppress_Initialization, as described above. @node Pragma Task_Name,Pragma Task_Storage,Pragma Suppress_Initialization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{104} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{106} @section Pragma Task_Name @@ -8355,7 +8374,7 @@ end; @end example @node Pragma Task_Storage,Pragma Test_Case,Pragma Task_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{105} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{107} @section Pragma Task_Storage @@ -8375,7 +8394,7 @@ created, depending on the target. This pragma can appear anywhere a type. @node Pragma Test_Case,Pragma Thread_Local_Storage,Pragma Task_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{106}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{107} +@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{108}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{109} @section Pragma Test_Case @@ -8431,7 +8450,7 @@ postcondition. Mode @code{Robustness} indicates that the precondition and postcondition of the subprogram should be ignored for this test case. @node Pragma Thread_Local_Storage,Pragma Time_Slice,Pragma Test_Case,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{108}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{109} +@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10a}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{10b} @section Pragma Thread_Local_Storage @@ -8469,7 +8488,7 @@ If this pragma is used on a system where @code{TLS} is not supported, then an error message will be generated and the program will be rejected. @node Pragma Time_Slice,Pragma Title,Pragma Thread_Local_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{10a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{10c} @section Pragma Time_Slice @@ -8485,7 +8504,7 @@ It is ignored if it is used in a system that does not allow this control, or if it appears in other than the main program unit. @node Pragma Title,Pragma Type_Invariant,Pragma Time_Slice,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{10b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{10d} @section Pragma Title @@ -8510,7 +8529,7 @@ notation is used, and named and positional notation can be mixed following the normal rules for procedure calls in Ada. @node Pragma Type_Invariant,Pragma Type_Invariant_Class,Pragma Title,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{10c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{10e} @section Pragma Type_Invariant @@ -8531,7 +8550,7 @@ controlled by the assertion identifier @code{Type_Invariant} rather than @code{Invariant}. @node Pragma Type_Invariant_Class,Pragma Unchecked_Union,Pragma Type_Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10d}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{10e} +@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{10f}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{110} @section Pragma Type_Invariant_Class @@ -8558,7 +8577,7 @@ policy that controls this pragma is @code{Type_Invariant'Class}, not @code{Type_Invariant_Class}. @node Pragma Unchecked_Union,Pragma Unevaluated_Use_Of_Old,Pragma Type_Invariant_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{10f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{111} @section Pragma Unchecked_Union @@ -8578,7 +8597,7 @@ version in all language modes (Ada 83, Ada 95, and Ada 2005). For full details, consult the Ada 2012 Reference Manual, section B.3.3. @node Pragma Unevaluated_Use_Of_Old,Pragma User_Aspect_Definition,Pragma Unchecked_Union,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{110} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{112} @section Pragma Unevaluated_Use_Of_Old @@ -8633,7 +8652,7 @@ uses up to the end of the corresponding statement sequence or sequence of package declarations. @node Pragma User_Aspect_Definition,Pragma Unimplemented_Unit,Pragma Unevaluated_Use_Of_Old,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-user-aspect-definition}@anchor{111} +@anchor{gnat_rm/implementation_defined_pragmas pragma-user-aspect-definition}@anchor{113} @section Pragma User_Aspect_Definition @@ -8665,7 +8684,7 @@ pragma. If multiple definitions are visible for some aspect at some point, then the definitions must agree. A predefined aspect cannot be redefined. @node Pragma Unimplemented_Unit,Pragma Universal_Aliasing,Pragma User_Aspect_Definition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{112} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{114} @section Pragma Unimplemented_Unit @@ -8685,7 +8704,7 @@ The abort only happens if code is being generated. Thus you can use specs of unimplemented packages in syntax or semantic checking mode. @node Pragma Universal_Aliasing,Pragma Unmodified,Pragma Unimplemented_Unit,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{113}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{114} +@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{115}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{116} @section Pragma Universal_Aliasing @@ -8703,7 +8722,7 @@ they need to be suppressed, see the section on @code{Optimization and Strict Aliasing} in the @cite{GNAT User’s Guide}. @node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Aliasing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{115}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{116} +@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{118} @section Pragma Unmodified @@ -8737,7 +8756,7 @@ Thus it is never necessary to use @code{pragma Unmodified} for such variables, though it is harmless to do so. @node Pragma Unreferenced,Pragma Unreferenced_Objects,Pragma Unmodified,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{118} +@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{119}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{11a} @section Pragma Unreferenced @@ -8799,7 +8818,7 @@ Thus it is never necessary to use @code{pragma Unreferenced} for such variables, though it is harmless to do so. @node Pragma Unreferenced_Objects,Pragma Unreserve_All_Interrupts,Pragma Unreferenced,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{119}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{11a} +@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11b}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{11c} @section Pragma Unreferenced_Objects @@ -8824,7 +8843,7 @@ compiler will automatically suppress unwanted warnings about these variables not being referenced. @node Pragma Unreserve_All_Interrupts,Pragma Unsuppress,Pragma Unreferenced_Objects,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{11b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{11d} @section Pragma Unreserve_All_Interrupts @@ -8837,15 +8856,15 @@ pragma Unreserve_All_Interrupts; Normally certain interrupts are reserved to the implementation. Any attempt to attach an interrupt causes Program_Error to be raised, as described in RM C.3.2(22). A typical example is the @code{SIGINT} interrupt used in -many systems for a @code{Ctrl-C} interrupt. Normally this interrupt is -reserved to the implementation, so that @code{Ctrl-C} can be used to +many systems for a @code{Ctrl}-@code{C} interrupt. Normally this interrupt is +reserved to the implementation, so that @code{Ctrl}-@code{C} can be used to interrupt execution. If the pragma @code{Unreserve_All_Interrupts} appears anywhere in any unit in a program, then all such interrupts are unreserved. This allows the program to handle these interrupts, but disables their standard functions. For example, if this pragma is used, then pressing -@code{Ctrl-C} will not automatically interrupt execution. However, +@code{Ctrl}-@code{C} will not automatically interrupt execution. However, a program can then handle the @code{SIGINT} interrupt as it chooses. For a full list of the interrupts handled in a specific implementation, @@ -8860,7 +8879,7 @@ handled, see pragma @code{Interrupt_State}, which subsumes the functionality of the @code{Unreserve_All_Interrupts} pragma. @node Pragma Unsuppress,Pragma Unused,Pragma Unreserve_All_Interrupts,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{11c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{11e} @section Pragma Unsuppress @@ -8896,7 +8915,7 @@ number of implementation-defined check names. See the description of pragma @code{Suppress} for full details. @node Pragma Unused,Pragma Use_VADS_Size,Pragma Unsuppress,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11d}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{11e} +@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{11f}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{120} @section Pragma Unused @@ -8930,7 +8949,7 @@ Thus it is never necessary to use @code{pragma Unused} for such variables, though it is harmless to do so. @node Pragma Use_VADS_Size,Pragma Validity_Checks,Pragma Unused,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{11f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{121} @section Pragma Use_VADS_Size @@ -8954,7 +8973,7 @@ as implemented in the VADS compiler. See description of the VADS_Size attribute for further details. @node Pragma Validity_Checks,Pragma Volatile,Pragma Use_VADS_Size,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{120} +@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{122} @section Pragma Validity_Checks @@ -9010,7 +9029,7 @@ A := C; -- C will be validity checked @end example @node Pragma Volatile,Pragma Volatile_Full_Access,Pragma Validity_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{121}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{122} +@anchor{gnat_rm/implementation_defined_pragmas id58}@anchor{123}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{124} @section Pragma Volatile @@ -9028,7 +9047,7 @@ implementation of pragma Volatile is upwards compatible with the implementation in DEC Ada 83. @node Pragma Volatile_Full_Access,Pragma Volatile_Function,Pragma Volatile,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id58}@anchor{123}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{124} +@anchor{gnat_rm/implementation_defined_pragmas id59}@anchor{125}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{126} @section Pragma Volatile_Full_Access @@ -9054,7 +9073,7 @@ is not to the whole object; the compiler is allowed (and generally will) access only part of the object in this case. @node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id59}@anchor{125}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{126} +@anchor{gnat_rm/implementation_defined_pragmas id60}@anchor{127}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{128} @section Pragma Volatile_Function @@ -9068,7 +9087,7 @@ For the semantics of this pragma, see the entry for aspect @code{Volatile_Functi in the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Warning_As_Error,Pragma Warnings,Pragma Volatile_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{127} +@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{129} @section Pragma Warning_As_Error @@ -9108,7 +9127,7 @@ you can use multiple pragma Warning_As_Error. The above use of patterns to match the message applies only to warning messages generated by the front end. This pragma can also be applied to -warnings provided by the back end and mentioned in @ref{128,,Pragma Warnings}. +warnings provided by the back end and mentioned in @ref{12a,,Pragma Warnings}. By using a single full `-Wxxx' switch in the pragma, such warnings can also be treated as errors. @@ -9158,7 +9177,7 @@ the tag is changed from “warning:” to “error:” and the string “[warning-as-error]” is appended to the end of the message. @node Pragma Warnings,Pragma Weak_External,Pragma Warning_As_Error,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id60}@anchor{129}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{128} +@anchor{gnat_rm/implementation_defined_pragmas id61}@anchor{12b}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{12a} @section Pragma Warnings @@ -9314,7 +9333,7 @@ selectively for each tool, and as a consequence to detect useless pragma Warnings with switch @code{-gnatw.w}. @node Pragma Weak_External,Pragma Wide_Character_Encoding,Pragma Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{12a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{12c} @section Pragma Weak_External @@ -9365,7 +9384,7 @@ end External_Module; @end example @node Pragma Wide_Character_Encoding,,Pragma Weak_External,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{12b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{12d} @section Pragma Wide_Character_Encoding @@ -9396,7 +9415,7 @@ encoding within that file, and does not affect withed units, specs, or subunits. @node Implementation Defined Aspects,Implementation Defined Attributes,Implementation Defined Pragmas,Top -@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{12c}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{12d}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{12e} +@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{12e}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{12f}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{130} @chapter Implementation Defined Aspects @@ -9493,6 +9512,7 @@ or attribute definition clause. * Aspect Part_Of:: * Aspect Persistent_BSS:: * Aspect Predicate:: +* Aspect Program_Exit:: * Aspect Pure_Function:: * Aspect Refined_Depends:: * Aspect Refined_Global:: @@ -9525,7 +9545,7 @@ or attribute definition clause. @end menu @node Aspect Abstract_State,Aspect Always_Terminates,,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{12f} +@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{131} @section Aspect Abstract_State @@ -9534,7 +9554,7 @@ or attribute definition clause. This aspect is equivalent to @ref{1e,,pragma Abstract_State}. @node Aspect Always_Terminates,Aspect Annotate,Aspect Abstract_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-always-terminates}@anchor{130} +@anchor{gnat_rm/implementation_defined_aspects aspect-always-terminates}@anchor{132} @section Aspect Always_Terminates @@ -9543,7 +9563,7 @@ This aspect is equivalent to @ref{1e,,pragma Abstract_State}. This boolean aspect is equivalent to @ref{29,,pragma Always_Terminates}. @node Aspect Annotate,Aspect Async_Readers,Aspect Always_Terminates,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{131} +@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{133} @section Aspect Annotate @@ -9570,7 +9590,7 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);} @end table @node Aspect Async_Readers,Aspect Async_Writers,Aspect Annotate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{132} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{134} @section Aspect Async_Readers @@ -9579,7 +9599,7 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);} This boolean aspect is equivalent to @ref{32,,pragma Async_Readers}. @node Aspect Async_Writers,Aspect Constant_After_Elaboration,Aspect Async_Readers,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{133} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{135} @section Aspect Async_Writers @@ -9588,7 +9608,7 @@ This boolean aspect is equivalent to @ref{32,,pragma Async_Readers}. This boolean aspect is equivalent to @ref{34,,pragma Async_Writers}. @node Aspect Constant_After_Elaboration,Aspect Contract_Cases,Aspect Async_Writers,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{134} +@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{136} @section Aspect Constant_After_Elaboration @@ -9597,7 +9617,7 @@ This boolean aspect is equivalent to @ref{34,,pragma Async_Writers}. This aspect is equivalent to @ref{44,,pragma Constant_After_Elaboration}. @node Aspect Contract_Cases,Aspect Depends,Aspect Constant_After_Elaboration,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{135} +@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{137} @section Aspect Contract_Cases @@ -9608,7 +9628,7 @@ of clauses being enclosed in parentheses so that syntactically it is an aggregate. @node Aspect Depends,Aspect Default_Initial_Condition,Aspect Contract_Cases,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{136} +@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{138} @section Aspect Depends @@ -9617,7 +9637,7 @@ aggregate. This aspect is equivalent to @ref{56,,pragma Depends}. @node Aspect Default_Initial_Condition,Aspect Dimension,Aspect Depends,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{137} +@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{139} @section Aspect Default_Initial_Condition @@ -9626,7 +9646,7 @@ This aspect is equivalent to @ref{56,,pragma Depends}. This aspect is equivalent to @ref{52,,pragma Default_Initial_Condition}. @node Aspect Dimension,Aspect Dimension_System,Aspect Default_Initial_Condition,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{138} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{13a} @section Aspect Dimension @@ -9662,7 +9682,7 @@ Note that when the dimensioned type is an integer type, then any dimension value must be an integer literal. @node Aspect Dimension_System,Aspect Disable_Controlled,Aspect Dimension,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{139} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{13b} @section Aspect Dimension_System @@ -9722,7 +9742,7 @@ See section ‘Performing Dimensionality Analysis in GNAT’ in the GNAT Users Guide for detailed examples of use of the dimension system. @node Aspect Disable_Controlled,Aspect Effective_Reads,Aspect Dimension_System,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{13a} +@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{13c} @section Aspect Disable_Controlled @@ -9735,7 +9755,7 @@ where for example you might want a record to be controlled or not depending on whether some run-time check is enabled or suppressed. @node Aspect Effective_Reads,Aspect Effective_Writes,Aspect Disable_Controlled,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{13b} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{13d} @section Aspect Effective_Reads @@ -9744,7 +9764,7 @@ whether some run-time check is enabled or suppressed. This aspect is equivalent to @ref{5b,,pragma Effective_Reads}. @node Aspect Effective_Writes,Aspect Exceptional_Cases,Aspect Effective_Reads,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{13c} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{13e} @section Aspect Effective_Writes @@ -9753,7 +9773,7 @@ This aspect is equivalent to @ref{5b,,pragma Effective_Reads}. This aspect is equivalent to @ref{5d,,pragma Effective_Writes}. @node Aspect Exceptional_Cases,Aspect Exit_Cases,Aspect Effective_Writes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-exceptional-cases}@anchor{13d} +@anchor{gnat_rm/implementation_defined_aspects aspect-exceptional-cases}@anchor{13f} @section Aspect Exceptional_Cases @@ -9768,7 +9788,7 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference Manual, section 6.1.9. @node Aspect Exit_Cases,Aspect Extensions_Visible,Aspect Exceptional_Cases,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-exit-cases}@anchor{13e} +@anchor{gnat_rm/implementation_defined_aspects aspect-exit-cases}@anchor{140} @section Aspect Exit_Cases @@ -9783,7 +9803,7 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference Manual, section 6.1.10. @node Aspect Extensions_Visible,Aspect Favor_Top_Level,Aspect Exit_Cases,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{13f} +@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{141} @section Aspect Extensions_Visible @@ -9792,7 +9812,7 @@ Manual, section 6.1.10. This aspect is equivalent to @ref{6d,,pragma Extensions_Visible}. @node Aspect Favor_Top_Level,Aspect Ghost,Aspect Extensions_Visible,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{140} +@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{142} @section Aspect Favor_Top_Level @@ -9801,7 +9821,7 @@ This aspect is equivalent to @ref{6d,,pragma Extensions_Visible}. This boolean aspect is equivalent to @ref{72,,pragma Favor_Top_Level}. @node Aspect Ghost,Aspect Ghost_Predicate,Aspect Favor_Top_Level,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{141} +@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{143} @section Aspect Ghost @@ -9810,7 +9830,7 @@ This boolean aspect is equivalent to @ref{72,,pragma Favor_Top_Level}. This aspect is equivalent to @ref{76,,pragma Ghost}. @node Aspect Ghost_Predicate,Aspect Global,Aspect Ghost,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-ghost-predicate}@anchor{142} +@anchor{gnat_rm/implementation_defined_aspects aspect-ghost-predicate}@anchor{144} @section Aspect Ghost_Predicate @@ -9823,7 +9843,7 @@ For the detailed semantics of this aspect, see the entry for subtype predicates in the SPARK Reference Manual, section 3.2.4. @node Aspect Global,Aspect Initial_Condition,Aspect Ghost_Predicate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{143} +@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{145} @section Aspect Global @@ -9832,7 +9852,7 @@ in the SPARK Reference Manual, section 3.2.4. This aspect is equivalent to @ref{78,,pragma Global}. @node Aspect Initial_Condition,Aspect Initializes,Aspect Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{144} +@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{146} @section Aspect Initial_Condition @@ -9841,7 +9861,7 @@ This aspect is equivalent to @ref{78,,pragma Global}. This aspect is equivalent to @ref{85,,pragma Initial_Condition}. @node Aspect Initializes,Aspect Inline_Always,Aspect Initial_Condition,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{145} +@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{147} @section Aspect Initializes @@ -9850,7 +9870,7 @@ This aspect is equivalent to @ref{85,,pragma Initial_Condition}. This aspect is equivalent to @ref{88,,pragma Initializes}. @node Aspect Inline_Always,Aspect Invariant,Aspect Initializes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{146} +@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{148} @section Aspect Inline_Always @@ -9859,7 +9879,7 @@ This aspect is equivalent to @ref{88,,pragma Initializes}. This boolean aspect is equivalent to @ref{8a,,pragma Inline_Always}. @node Aspect Invariant,Aspect Invariant’Class,Aspect Inline_Always,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{147} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{149} @section Aspect Invariant @@ -9870,18 +9890,18 @@ synonym for the language defined aspect @code{Type_Invariant} except that it is separately controllable using pragma @code{Assertion_Policy}. @node Aspect Invariant’Class,Aspect Iterable,Aspect Invariant,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{148} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{14a} @section Aspect Invariant’Class @geindex Invariant'Class -This aspect is equivalent to @ref{10e,,pragma Type_Invariant_Class}. It is a +This aspect is equivalent to @ref{110,,pragma Type_Invariant_Class}. It is a synonym for the language defined aspect @code{Type_Invariant'Class} except that it is separately controllable using pragma @code{Assertion_Policy}. @node Aspect Iterable,Aspect Linker_Section,Aspect Invariant’Class,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{149} +@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{14b} @section Aspect Iterable @@ -9965,7 +9985,7 @@ function Get_Element (Cont : Container; Position : Cursor) return Element_Type; This aspect is used in the GNAT-defined formal container packages. @node Aspect Linker_Section,Aspect Local_Restrictions,Aspect Iterable,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{14a} +@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{14c} @section Aspect Linker_Section @@ -9974,7 +9994,7 @@ This aspect is used in the GNAT-defined formal container packages. This aspect is equivalent to @ref{9a,,pragma Linker_Section}. @node Aspect Local_Restrictions,Aspect Lock_Free,Aspect Linker_Section,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-local-restrictions}@anchor{14b} +@anchor{gnat_rm/implementation_defined_aspects aspect-local-restrictions}@anchor{14d} @section Aspect Local_Restrictions @@ -10028,7 +10048,7 @@ case of a declaration that occurs within nested packages that each have a Local_Restrictions specification). @node Aspect Lock_Free,Aspect Max_Queue_Length,Aspect Local_Restrictions,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{14c} +@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{14e} @section Aspect Lock_Free @@ -10037,7 +10057,7 @@ a Local_Restrictions specification). This boolean aspect is equivalent to @ref{9c,,pragma Lock_Free}. @node Aspect Max_Queue_Length,Aspect No_Caching,Aspect Lock_Free,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{14d} +@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{14f} @section Aspect Max_Queue_Length @@ -10046,7 +10066,7 @@ This boolean aspect is equivalent to @ref{9c,,pragma Lock_Free}. This aspect is equivalent to @ref{a4,,pragma Max_Queue_Length}. @node Aspect No_Caching,Aspect No_Elaboration_Code_All,Aspect Max_Queue_Length,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{14e} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{150} @section Aspect No_Caching @@ -10055,7 +10075,7 @@ This aspect is equivalent to @ref{a4,,pragma Max_Queue_Length}. This boolean aspect is equivalent to @ref{a7,,pragma No_Caching}. @node Aspect No_Elaboration_Code_All,Aspect No_Inline,Aspect No_Caching,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{14f} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{151} @section Aspect No_Elaboration_Code_All @@ -10065,7 +10085,7 @@ This aspect is equivalent to @ref{aa,,pragma No_Elaboration_Code_All} for a program unit. @node Aspect No_Inline,Aspect No_Raise,Aspect No_Elaboration_Code_All,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{150} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{152} @section Aspect No_Inline @@ -10074,7 +10094,7 @@ for a program unit. This boolean aspect is equivalent to @ref{ad,,pragma No_Inline}. @node Aspect No_Raise,Aspect No_Tagged_Streams,Aspect No_Inline,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-raise}@anchor{151} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-raise}@anchor{153} @section Aspect No_Raise @@ -10083,7 +10103,7 @@ This boolean aspect is equivalent to @ref{ad,,pragma No_Inline}. This boolean aspect is equivalent to @ref{af,,pragma No_Raise}. @node Aspect No_Tagged_Streams,Aspect No_Task_Parts,Aspect No_Raise,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{152} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{154} @section Aspect No_Tagged_Streams @@ -10094,7 +10114,7 @@ argument specifying a root tagged type (thus this aspect can only be applied to such a type). @node Aspect No_Task_Parts,Aspect Object_Size,Aspect No_Tagged_Streams,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{153} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{155} @section Aspect No_Task_Parts @@ -10110,16 +10130,16 @@ away certain tasking-related code that would otherwise be needed for T’Class, because descendants of T might contain tasks. @node Aspect Object_Size,Aspect Obsolescent,Aspect No_Task_Parts,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{154} +@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{156} @section Aspect Object_Size @geindex Object_Size -This aspect is equivalent to @ref{155,,attribute Object_Size}. +This aspect is equivalent to @ref{157,,attribute Object_Size}. @node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{156} +@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{158} @section Aspect Obsolescent @@ -10130,7 +10150,7 @@ evaluation of this aspect happens at the point of occurrence, it is not delayed until the freeze point. @node Aspect Part_Of,Aspect Persistent_BSS,Aspect Obsolescent,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{157} +@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{159} @section Aspect Part_Of @@ -10139,7 +10159,7 @@ delayed until the freeze point. This aspect is equivalent to @ref{bc,,pragma Part_Of}. @node Aspect Persistent_BSS,Aspect Predicate,Aspect Part_Of,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{158} +@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{15a} @section Aspect Persistent_BSS @@ -10147,8 +10167,8 @@ This aspect is equivalent to @ref{bc,,pragma Part_Of}. This boolean aspect is equivalent to @ref{c0,,pragma Persistent_BSS}. -@node Aspect Predicate,Aspect Pure_Function,Aspect Persistent_BSS,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{159} +@node Aspect Predicate,Aspect Program_Exit,Aspect Persistent_BSS,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{15b} @section Aspect Predicate @@ -10161,53 +10181,62 @@ predicate is static or dynamic is controlled by the form of the expression. It is also separately controllable using pragma @code{Assertion_Policy}. -@node Aspect Pure_Function,Aspect Refined_Depends,Aspect Predicate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{15a} +@node Aspect Program_Exit,Aspect Pure_Function,Aspect Predicate,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-program-exit}@anchor{15c} +@section Aspect Program_Exit + + +@geindex Program_Exit + +This boolean aspect is equivalent to @ref{d0,,pragma Program_Exit}. + +@node Aspect Pure_Function,Aspect Refined_Depends,Aspect Program_Exit,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{15d} @section Aspect Pure_Function @geindex Pure_Function -This boolean aspect is equivalent to @ref{d3,,pragma Pure_Function}. +This boolean aspect is equivalent to @ref{d5,,pragma Pure_Function}. @node Aspect Refined_Depends,Aspect Refined_Global,Aspect Pure_Function,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{15b} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{15e} @section Aspect Refined_Depends @geindex Refined_Depends -This aspect is equivalent to @ref{d7,,pragma Refined_Depends}. +This aspect is equivalent to @ref{d9,,pragma Refined_Depends}. @node Aspect Refined_Global,Aspect Refined_Post,Aspect Refined_Depends,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{15c} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{15f} @section Aspect Refined_Global @geindex Refined_Global -This aspect is equivalent to @ref{d9,,pragma Refined_Global}. +This aspect is equivalent to @ref{db,,pragma Refined_Global}. @node Aspect Refined_Post,Aspect Refined_State,Aspect Refined_Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{15d} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{160} @section Aspect Refined_Post @geindex Refined_Post -This aspect is equivalent to @ref{db,,pragma Refined_Post}. +This aspect is equivalent to @ref{dd,,pragma Refined_Post}. @node Aspect Refined_State,Aspect Relaxed_Initialization,Aspect Refined_Post,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{15e} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{161} @section Aspect Refined_State @geindex Refined_State -This aspect is equivalent to @ref{dd,,pragma Refined_State}. +This aspect is equivalent to @ref{df,,pragma Refined_State}. @node Aspect Relaxed_Initialization,Aspect Remote_Access_Type,Aspect Refined_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{15f} +@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{162} @section Aspect Relaxed_Initialization @@ -10217,82 +10246,82 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference Manual, section 6.10. @node Aspect Remote_Access_Type,Aspect Scalar_Storage_Order,Aspect Relaxed_Initialization,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{160} +@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{163} @section Aspect Remote_Access_Type @geindex Remote_Access_Type -This aspect is equivalent to @ref{e0,,pragma Remote_Access_Type}. +This aspect is equivalent to @ref{e2,,pragma Remote_Access_Type}. @node Aspect Scalar_Storage_Order,Aspect Secondary_Stack_Size,Aspect Remote_Access_Type,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{161} +@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{164} @section Aspect Scalar_Storage_Order @geindex Scalar_Storage_Order -This aspect is equivalent to a @ref{162,,attribute Scalar_Storage_Order}. +This aspect is equivalent to a @ref{165,,attribute Scalar_Storage_Order}. @node Aspect Secondary_Stack_Size,Aspect Shared,Aspect Scalar_Storage_Order,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{163} +@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{166} @section Aspect Secondary_Stack_Size @geindex Secondary_Stack_Size -This aspect is equivalent to @ref{e6,,pragma Secondary_Stack_Size}. +This aspect is equivalent to @ref{e8,,pragma Secondary_Stack_Size}. @node Aspect Shared,Aspect Side_Effects,Aspect Secondary_Stack_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{164} +@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{167} @section Aspect Shared @geindex Shared -This boolean aspect is equivalent to @ref{e9,,pragma Shared} +This boolean aspect is equivalent to @ref{eb,,pragma Shared} and is thus a synonym for aspect @code{Atomic}. @node Aspect Side_Effects,Aspect Simple_Storage_Pool,Aspect Shared,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-side-effects}@anchor{165} +@anchor{gnat_rm/implementation_defined_aspects aspect-side-effects}@anchor{168} @section Aspect Side_Effects @geindex Side_Effects -This aspect is equivalent to @ref{ed,,pragma Side_Effects}. +This aspect is equivalent to @ref{ef,,pragma Side_Effects}. @node Aspect Simple_Storage_Pool,Aspect Simple_Storage_Pool_Type,Aspect Side_Effects,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{166} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{169} @section Aspect Simple_Storage_Pool @geindex Simple_Storage_Pool -This aspect is equivalent to @ref{f0,,attribute Simple_Storage_Pool}. +This aspect is equivalent to @ref{f2,,attribute Simple_Storage_Pool}. @node Aspect Simple_Storage_Pool_Type,Aspect SPARK_Mode,Aspect Simple_Storage_Pool,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{167} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{16a} @section Aspect Simple_Storage_Pool_Type @geindex Simple_Storage_Pool_Type -This boolean aspect is equivalent to @ref{ef,,pragma Simple_Storage_Pool_Type}. +This boolean aspect is equivalent to @ref{f1,,pragma Simple_Storage_Pool_Type}. @node Aspect SPARK_Mode,Aspect Subprogram_Variant,Aspect Simple_Storage_Pool_Type,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{168} +@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{16b} @section Aspect SPARK_Mode @geindex SPARK_Mode -This aspect is equivalent to @ref{f7,,pragma SPARK_Mode} and +This aspect is equivalent to @ref{f9,,pragma SPARK_Mode} and may be specified for either or both of the specification and body of a subprogram or package. @node Aspect Subprogram_Variant,Aspect Suppress_Debug_Info,Aspect SPARK_Mode,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-subprogram-variant}@anchor{169} +@anchor{gnat_rm/implementation_defined_aspects aspect-subprogram-variant}@anchor{16c} @section Aspect Subprogram_Variant @@ -10302,83 +10331,83 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference Manual, section 6.1.8. @node Aspect Suppress_Debug_Info,Aspect Suppress_Initialization,Aspect Subprogram_Variant,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{16a} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{16d} @section Aspect Suppress_Debug_Info @geindex Suppress_Debug_Info -This boolean aspect is equivalent to @ref{100,,pragma Suppress_Debug_Info}. +This boolean aspect is equivalent to @ref{102,,pragma Suppress_Debug_Info}. @node Aspect Suppress_Initialization,Aspect Test_Case,Aspect Suppress_Debug_Info,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{16b} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{16e} @section Aspect Suppress_Initialization @geindex Suppress_Initialization -This boolean aspect is equivalent to @ref{103,,pragma Suppress_Initialization}. +This boolean aspect is equivalent to @ref{105,,pragma Suppress_Initialization}. @node Aspect Test_Case,Aspect Thread_Local_Storage,Aspect Suppress_Initialization,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{16c} +@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{16f} @section Aspect Test_Case @geindex Test_Case -This aspect is equivalent to @ref{107,,pragma Test_Case}. +This aspect is equivalent to @ref{109,,pragma Test_Case}. @node Aspect Thread_Local_Storage,Aspect Universal_Aliasing,Aspect Test_Case,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{16d} +@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{170} @section Aspect Thread_Local_Storage @geindex Thread_Local_Storage -This boolean aspect is equivalent to @ref{109,,pragma Thread_Local_Storage}. +This boolean aspect is equivalent to @ref{10b,,pragma Thread_Local_Storage}. @node Aspect Universal_Aliasing,Aspect Unmodified,Aspect Thread_Local_Storage,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{16e} +@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{171} @section Aspect Universal_Aliasing @geindex Universal_Aliasing -This boolean aspect is equivalent to @ref{114,,pragma Universal_Aliasing}. +This boolean aspect is equivalent to @ref{116,,pragma Universal_Aliasing}. @node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Aliasing,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{16f} +@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{172} @section Aspect Unmodified @geindex Unmodified -This boolean aspect is equivalent to @ref{116,,pragma Unmodified}. +This boolean aspect is equivalent to @ref{118,,pragma Unmodified}. @node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{170} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{173} @section Aspect Unreferenced @geindex Unreferenced -This boolean aspect is equivalent to @ref{118,,pragma Unreferenced}. +This boolean aspect is equivalent to @ref{11a,,pragma Unreferenced}. When using the @code{-gnat2022} switch, this aspect is also supported on formal parameters, which is in particular the only form possible for expression functions. @node Aspect Unreferenced_Objects,Aspect User_Aspect,Aspect Unreferenced,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{171} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{174} @section Aspect Unreferenced_Objects @geindex Unreferenced_Objects -This boolean aspect is equivalent to @ref{11a,,pragma Unreferenced_Objects}. +This boolean aspect is equivalent to @ref{11c,,pragma Unreferenced_Objects}. @node Aspect User_Aspect,Aspect Value_Size,Aspect Unreferenced_Objects,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-user-aspect}@anchor{172} +@anchor{gnat_rm/implementation_defined_aspects aspect-user-aspect}@anchor{175} @section Aspect User_Aspect @@ -10391,45 +10420,45 @@ replicating the set of aspect specifications associated with the named pragma-defined aspect. @node Aspect Value_Size,Aspect Volatile_Full_Access,Aspect User_Aspect,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{173} +@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{176} @section Aspect Value_Size @geindex Value_Size -This aspect is equivalent to @ref{174,,attribute Value_Size}. +This aspect is equivalent to @ref{177,,attribute Value_Size}. @node Aspect Volatile_Full_Access,Aspect Volatile_Function,Aspect Value_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{175} +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{178} @section Aspect Volatile_Full_Access @geindex Volatile_Full_Access -This boolean aspect is equivalent to @ref{124,,pragma Volatile_Full_Access}. +This boolean aspect is equivalent to @ref{126,,pragma Volatile_Full_Access}. @node Aspect Volatile_Function,Aspect Warnings,Aspect Volatile_Full_Access,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{176} +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{179} @section Aspect Volatile_Function @geindex Volatile_Function -This boolean aspect is equivalent to @ref{126,,pragma Volatile_Function}. +This boolean aspect is equivalent to @ref{128,,pragma Volatile_Function}. @node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{177} +@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{17a} @section Aspect Warnings @geindex Warnings -This aspect is equivalent to the two argument form of @ref{128,,pragma Warnings}, +This aspect is equivalent to the two argument form of @ref{12a,,pragma Warnings}, where the first argument is @code{ON} or @code{OFF} and the second argument is the entity. @node Implementation Defined Attributes,Standard and Implementation Defined Restrictions,Implementation Defined Aspects,Top -@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{178}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{179}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8} +@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{17b}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{17c}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8} @chapter Implementation Defined Attributes @@ -10535,7 +10564,7 @@ consideration, you should minimize the use of these attributes. @end menu @node Attribute Abort_Signal,Attribute Address_Size,,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{17a} +@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{17d} @section Attribute Abort_Signal @@ -10549,7 +10578,7 @@ completely outside the normal semantics of Ada, for a user program to intercept the abort exception). @node Attribute Address_Size,Attribute Asm_Input,Attribute Abort_Signal,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{17b} +@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{17e} @section Attribute Address_Size @@ -10565,7 +10594,7 @@ reference to System.Address’Size is nonstatic because Address is a private type. @node Attribute Asm_Input,Attribute Asm_Output,Attribute Address_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{17c} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{17f} @section Attribute Asm_Input @@ -10579,10 +10608,10 @@ to be a static expression, and is the constraint for the parameter, value to be used as the input argument. The possible values for the constant are the same as those used in the RTL, and are dependent on the configuration file used to built the GCC back end. -@ref{17d,,Machine Code Insertions} +@ref{180,,Machine Code Insertions} @node Attribute Asm_Output,Attribute Atomic_Always_Lock_Free,Attribute Asm_Input,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{17e} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{181} @section Attribute Asm_Output @@ -10598,10 +10627,10 @@ result. The possible values for constraint are the same as those used in the RTL, and are dependent on the configuration file used to build the GCC back end. If there are no output operands, then this argument may either be omitted, or explicitly given as @code{No_Output_Operands}. -@ref{17d,,Machine Code Insertions} +@ref{180,,Machine Code Insertions} @node Attribute Atomic_Always_Lock_Free,Attribute Bit,Attribute Asm_Output,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{17f} +@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{182} @section Attribute Atomic_Always_Lock_Free @@ -10612,7 +10641,7 @@ result indicates whether atomic operations are supported by the target for the given type. @node Attribute Bit,Attribute Bit_Position,Attribute Atomic_Always_Lock_Free,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{180} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{183} @section Attribute Bit @@ -10643,7 +10672,7 @@ This attribute is designed to be compatible with the DEC Ada 83 definition and implementation of the @code{Bit} attribute. @node Attribute Bit_Position,Attribute Code_Address,Attribute Bit,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{181} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{184} @section Attribute Bit_Position @@ -10658,7 +10687,7 @@ type `universal_integer'. The value depends only on the field the containing record @code{R}. @node Attribute Code_Address,Attribute Compiler_Version,Attribute Bit_Position,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{182} +@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{185} @section Attribute Code_Address @@ -10701,7 +10730,7 @@ the same value as is returned by the corresponding @code{'Address} attribute. @node Attribute Compiler_Version,Attribute Constrained,Attribute Code_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{183} +@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{186} @section Attribute Compiler_Version @@ -10712,7 +10741,7 @@ prefix) yields a static string identifying the version of the compiler being used to compile the unit containing the attribute reference. @node Attribute Constrained,Attribute Default_Bit_Order,Attribute Compiler_Version,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{184} +@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{187} @section Attribute Constrained @@ -10727,7 +10756,7 @@ record type without discriminants is always @code{True}. This usage is compatible with older Ada compilers, including notably DEC Ada. @node Attribute Default_Bit_Order,Attribute Default_Scalar_Storage_Order,Attribute Constrained,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{185} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{188} @section Attribute Default_Bit_Order @@ -10744,7 +10773,7 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for @code{Default_Bit_Order} in package @code{System}. @node Attribute Default_Scalar_Storage_Order,Attribute Deref,Attribute Default_Bit_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{186} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{189} @section Attribute Default_Scalar_Storage_Order @@ -10761,7 +10790,7 @@ equal to @code{Default_Bit_Order} if unspecified) as a @code{System.Bit_Order} value. This is a static attribute. @node Attribute Deref,Attribute Descriptor_Size,Attribute Default_Scalar_Storage_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{187} +@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{18a} @section Attribute Deref @@ -10774,7 +10803,7 @@ a named access-to-@cite{typ} type, except that it yields a variable, so it can b used on the left side of an assignment. @node Attribute Descriptor_Size,Attribute Elaborated,Attribute Deref,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{188} +@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{18b} @section Attribute Descriptor_Size @@ -10803,7 +10832,7 @@ since @code{Positive} has an alignment of 4, the size of the descriptor is which yields a size of 32 bits, i.e. including 16 bits of padding. @node Attribute Elaborated,Attribute Elab_Body,Attribute Descriptor_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{189} +@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{18c} @section Attribute Elaborated @@ -10818,7 +10847,7 @@ units has been completed. An exception is for units which need no elaboration, the value is always False for such units. @node Attribute Elab_Body,Attribute Elab_Spec,Attribute Elaborated,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{18a} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{18d} @section Attribute Elab_Body @@ -10834,7 +10863,7 @@ e.g., if it is necessary to do selective re-elaboration to fix some error. @node Attribute Elab_Spec,Attribute Elab_Subp_Body,Attribute Elab_Body,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{18b} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{18e} @section Attribute Elab_Spec @@ -10850,7 +10879,7 @@ Ada code, e.g., if it is necessary to do selective re-elaboration to fix some error. @node Attribute Elab_Subp_Body,Attribute Emax,Attribute Elab_Spec,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{18c} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{18f} @section Attribute Elab_Subp_Body @@ -10864,7 +10893,7 @@ elaboration procedure by the binder in CodePeer mode only and is unrecognized otherwise. @node Attribute Emax,Attribute Enabled,Attribute Elab_Subp_Body,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{18d} +@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{190} @section Attribute Emax @@ -10877,7 +10906,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Enabled,Attribute Enum_Rep,Attribute Emax,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{18e} +@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{191} @section Attribute Enabled @@ -10901,7 +10930,7 @@ a @code{pragma Suppress} or @code{pragma Unsuppress} before instantiating the package or subprogram, controlling whether the check will be present. @node Attribute Enum_Rep,Attribute Enum_Val,Attribute Enabled,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{18f} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{192} @section Attribute Enum_Rep @@ -10941,7 +10970,7 @@ integer calculation is done at run time, then the call to @code{Enum_Rep} may raise @code{Constraint_Error}. @node Attribute Enum_Val,Attribute Epsilon,Attribute Enum_Rep,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{190} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{193} @section Attribute Enum_Val @@ -10967,7 +10996,7 @@ absence of an enumeration representation clause. This is a static attribute (i.e., the result is static if the argument is static). @node Attribute Epsilon,Attribute Fast_Math,Attribute Enum_Val,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{191} +@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{194} @section Attribute Epsilon @@ -10980,7 +11009,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Fast_Math,Attribute Finalization_Size,Attribute Epsilon,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{192} +@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{195} @section Attribute Fast_Math @@ -10991,7 +11020,7 @@ prefix) yields a static Boolean value that is True if pragma @code{Fast_Math} is active, and False otherwise. @node Attribute Finalization_Size,Attribute Fixed_Value,Attribute Fast_Math,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{193} +@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{196} @section Attribute Finalization_Size @@ -11009,7 +11038,7 @@ class-wide type whose tag denotes a type with no controlled parts. Note that only heap-allocated objects contain finalization data. @node Attribute Fixed_Value,Attribute From_Any,Attribute Finalization_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{194} +@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{197} @section Attribute Fixed_Value @@ -11036,7 +11065,7 @@ This attribute is primarily intended for use in implementation of the input-output functions for fixed-point values. @node Attribute From_Any,Attribute Has_Access_Values,Attribute Fixed_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{195} +@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{198} @section Attribute From_Any @@ -11046,7 +11075,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Has_Access_Values,Attribute Has_Discriminants,Attribute From_Any,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{196} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{199} @section Attribute Has_Access_Values @@ -11064,7 +11093,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has access values. @node Attribute Has_Discriminants,Attribute Has_Tagged_Values,Attribute Has_Access_Values,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{197} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{19a} @section Attribute Has_Discriminants @@ -11080,7 +11109,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has discriminants. @node Attribute Has_Tagged_Values,Attribute Img,Attribute Has_Discriminants,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{198} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{19b} @section Attribute Has_Tagged_Values @@ -11097,7 +11126,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has access values. @node Attribute Img,Attribute Initialized,Attribute Has_Tagged_Values,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{199} +@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{19c} @section Attribute Img @@ -11127,7 +11156,7 @@ that returns the appropriate string when called. This means that in an instantiation as a function parameter. @node Attribute Initialized,Attribute Integer_Value,Attribute Img,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{19a} +@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{19d} @section Attribute Initialized @@ -11137,7 +11166,7 @@ For the syntax and semantics of this attribute, see the SPARK 2014 Reference Manual, section 6.10. @node Attribute Integer_Value,Attribute Invalid_Value,Attribute Initialized,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{19b} +@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{19e} @section Attribute Integer_Value @@ -11165,7 +11194,7 @@ This attribute is primarily intended for use in implementation of the standard input-output functions for fixed-point values. @node Attribute Invalid_Value,Attribute Large,Attribute Integer_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{19c} +@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{19f} @section Attribute Invalid_Value @@ -11179,7 +11208,7 @@ including the ability to modify the value with the binder -Sxx flag and relevant environment variables at run time. @node Attribute Large,Attribute Library_Level,Attribute Invalid_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{19d} +@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{1a0} @section Attribute Large @@ -11192,7 +11221,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Library_Level,Attribute Loop_Entry,Attribute Large,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{19e} +@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{1a1} @section Attribute Library_Level @@ -11218,7 +11247,7 @@ end Gen; @end example @node Attribute Loop_Entry,Attribute Machine_Size,Attribute Library_Level,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{19f} +@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{1a2} @section Attribute Loop_Entry @@ -11251,7 +11280,7 @@ entry. This copy is not performed if the loop is not entered, or if the corresponding pragmas are ignored or disabled. @node Attribute Machine_Size,Attribute Mantissa,Attribute Loop_Entry,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{1a0} +@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{1a3} @section Attribute Machine_Size @@ -11261,7 +11290,7 @@ This attribute is identical to the @code{Object_Size} attribute. It is provided for compatibility with the DEC Ada 83 attribute of this name. @node Attribute Mantissa,Attribute Maximum_Alignment,Attribute Machine_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{1a1} +@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{1a4} @section Attribute Mantissa @@ -11274,7 +11303,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Maximum_Alignment,Attribute Max_Integer_Size,Attribute Mantissa,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{1a2}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{1a3} +@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{1a5}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{1a6} @section Attribute Maximum_Alignment @@ -11290,7 +11319,7 @@ for an object, guaranteeing that it is properly aligned in all cases. @node Attribute Max_Integer_Size,Attribute Mechanism_Code,Attribute Maximum_Alignment,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{1a4} +@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{1a7} @section Attribute Max_Integer_Size @@ -11301,7 +11330,7 @@ prefix) provides the size of the largest supported integer type for the target. The result is a static constant. @node Attribute Mechanism_Code,Attribute Null_Parameter,Attribute Max_Integer_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{1a5} +@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{1a8} @section Attribute Mechanism_Code @@ -11332,7 +11361,7 @@ by reference @end table @node Attribute Null_Parameter,Attribute Object_Size,Attribute Mechanism_Code,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{1a6} +@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{1a9} @section Attribute Null_Parameter @@ -11357,7 +11386,7 @@ There is no way of indicating this without the @code{Null_Parameter} attribute. @node Attribute Object_Size,Attribute Old,Attribute Null_Parameter,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{155}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{1a7} +@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{157}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{1aa} @section Attribute Object_Size @@ -11427,7 +11456,7 @@ Similar additional checks are performed in other contexts requiring statically matching subtypes. @node Attribute Old,Attribute Passed_By_Reference,Attribute Object_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{1a8} +@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{1ab} @section Attribute Old @@ -11442,7 +11471,7 @@ definition are allowed under control of implementation defined pragma @code{Unevaluated_Use_Of_Old}. @node Attribute Passed_By_Reference,Attribute Pool_Address,Attribute Old,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{1a9} +@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{1ac} @section Attribute Passed_By_Reference @@ -11458,7 +11487,7 @@ passed by copy in calls. For scalar types, the result is always @code{False} and is static. For non-scalar types, the result is nonstatic. @node Attribute Pool_Address,Attribute Range_Length,Attribute Passed_By_Reference,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{1aa} +@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{1ad} @section Attribute Pool_Address @@ -11480,7 +11509,7 @@ For an object created by @code{new}, @code{Ptr.all'Pool_Address} is what is passed to @code{Allocate} and returned from @code{Deallocate}. @node Attribute Range_Length,Attribute Restriction_Set,Attribute Pool_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{1ab} +@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{1ae} @section Attribute Range_Length @@ -11493,7 +11522,7 @@ applied to the index subtype of a one dimensional array always gives the same result as @code{Length} applied to the array itself. @node Attribute Restriction_Set,Attribute Result,Attribute Range_Length,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{1ac} +@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{1af} @section Attribute Restriction_Set @@ -11563,7 +11592,7 @@ Restrictions pragma, they are not analyzed semantically, so they do not have a type. @node Attribute Result,Attribute Round,Attribute Restriction_Set,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{1ad} +@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{1b0} @section Attribute Result @@ -11576,7 +11605,7 @@ For a further discussion of the use of this attribute and examples of its use, see the description of pragma Postcondition. @node Attribute Round,Attribute Safe_Emax,Attribute Result,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-round}@anchor{1ae} +@anchor{gnat_rm/implementation_defined_attributes attribute-round}@anchor{1b1} @section Attribute Round @@ -11587,7 +11616,7 @@ also permits the use of the @code{'Round} attribute for ordinary fixed point types. @node Attribute Safe_Emax,Attribute Safe_Large,Attribute Round,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{1af} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{1b2} @section Attribute Safe_Emax @@ -11600,7 +11629,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Safe_Large,Attribute Safe_Small,Attribute Safe_Emax,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{1b0} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{1b3} @section Attribute Safe_Large @@ -11613,7 +11642,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Safe_Small,Attribute Scalar_Storage_Order,Attribute Safe_Large,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{1b1} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{1b4} @section Attribute Safe_Small @@ -11626,7 +11655,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Scalar_Storage_Order,Attribute Simple_Storage_Pool,Attribute Safe_Small,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{162}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{1b2} +@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{165}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{1b5} @section Attribute Scalar_Storage_Order @@ -11789,7 +11818,7 @@ Note that debuggers may be unable to display the correct value of scalar components of a type for which the opposite storage order is specified. @node Attribute Simple_Storage_Pool,Attribute Small,Attribute Scalar_Storage_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{f0}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{1b3} +@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{f2}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{1b6} @section Attribute Simple_Storage_Pool @@ -11852,7 +11881,7 @@ as defined in section 13.11.2 of the Ada Reference Manual, except that the term `simple storage pool' is substituted for `storage pool'. @node Attribute Small,Attribute Small_Denominator,Attribute Simple_Storage_Pool,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1b4} +@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1b7} @section Attribute Small @@ -11868,7 +11897,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute when applied to floating-point types. @node Attribute Small_Denominator,Attribute Small_Numerator,Attribute Small,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{1b5} +@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{1b8} @section Attribute Small_Denominator @@ -11881,7 +11910,7 @@ denominator in the representation of @code{typ'Small} as a rational number with coprime factors (i.e. as an irreducible fraction). @node Attribute Small_Numerator,Attribute Storage_Unit,Attribute Small_Denominator,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1b6} +@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1b9} @section Attribute Small_Numerator @@ -11894,7 +11923,7 @@ numerator in the representation of @code{typ'Small} as a rational number with coprime factors (i.e. as an irreducible fraction). @node Attribute Storage_Unit,Attribute Stub_Type,Attribute Small_Numerator,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1b7} +@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1ba} @section Attribute Storage_Unit @@ -11904,7 +11933,7 @@ with coprime factors (i.e. as an irreducible fraction). prefix) provides the same value as @code{System.Storage_Unit}. @node Attribute Stub_Type,Attribute System_Allocator_Alignment,Attribute Storage_Unit,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1b8} +@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1bb} @section Attribute Stub_Type @@ -11928,7 +11957,7 @@ unit @code{System.Partition_Interface}. Use of this attribute will create an implicit dependency on this unit. @node Attribute System_Allocator_Alignment,Attribute Target_Name,Attribute Stub_Type,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1b9} +@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1bc} @section Attribute System_Allocator_Alignment @@ -11945,7 +11974,7 @@ with alignment too large or to enable a realignment circuitry if the alignment request is larger than this value. @node Attribute Target_Name,Attribute To_Address,Attribute System_Allocator_Alignment,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1ba} +@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1bd} @section Attribute Target_Name @@ -11958,7 +11987,7 @@ standard gcc target name without the terminating slash (for example, GNAT 5.0 on windows yields “i586-pc-mingw32msv”). @node Attribute To_Address,Attribute To_Any,Attribute Target_Name,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1bb} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1be} @section Attribute To_Address @@ -11981,7 +12010,7 @@ modular manner (e.g., -1 means the same as 16#FFFF_FFFF# on a 32 bits machine). @node Attribute To_Any,Attribute Type_Class,Attribute To_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1bc} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1bf} @section Attribute To_Any @@ -11991,7 +12020,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Type_Class,Attribute Type_Key,Attribute To_Any,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1bd} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1c0} @section Attribute Type_Class @@ -12021,7 +12050,7 @@ applies to all concurrent types. This attribute is designed to be compatible with the DEC Ada 83 attribute of the same name. @node Attribute Type_Key,Attribute TypeCode,Attribute Type_Class,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1be} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1c1} @section Attribute Type_Key @@ -12033,7 +12062,7 @@ about the type or subtype. This provides improved compatibility with other implementations that support this attribute. @node Attribute TypeCode,Attribute Unconstrained_Array,Attribute Type_Key,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1bf} +@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1c2} @section Attribute TypeCode @@ -12043,7 +12072,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Unconstrained_Array,Attribute Universal_Literal_String,Attribute TypeCode,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1c0} +@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1c3} @section Attribute Unconstrained_Array @@ -12057,7 +12086,7 @@ still static, and yields the result of applying this test to the generic actual. @node Attribute Universal_Literal_String,Attribute Unrestricted_Access,Attribute Unconstrained_Array,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1c1} +@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1c4} @section Attribute Universal_Literal_String @@ -12085,7 +12114,7 @@ end; @end example @node Attribute Unrestricted_Access,Attribute Update,Attribute Universal_Literal_String,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1c2} +@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1c5} @section Attribute Unrestricted_Access @@ -12272,7 +12301,7 @@ In general this is a risky approach. It may appear to “work” but such uses o of GNAT to another, so are best avoided if possible. @node Attribute Update,Attribute Valid_Value,Attribute Unrestricted_Access,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1c3} +@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1c6} @section Attribute Update @@ -12353,19 +12382,19 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30); which changes element (1,2) to 20 and (3,4) to 30. @node Attribute Valid_Value,Attribute Valid_Scalars,Attribute Update,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-value}@anchor{1c4} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-value}@anchor{1c7} @section Attribute Valid_Value @geindex Valid_Value The @code{'Valid_Value} attribute is defined for enumeration types other than -those in package Standard. This attribute is a function that takes -a String, and returns Boolean. @code{T'Valid_Value (S)} returns True -if and only if @code{T'Value (S)} would not raise Constraint_Error. +those in package Standard or types derived from those types. This attribute is +a function that takes a String, and returns Boolean. @code{T'Valid_Value (S)} +returns True if and only if @code{T'Value (S)} would not raise Constraint_Error. @node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1c5} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1c8} @section Attribute Valid_Scalars @@ -12399,7 +12428,7 @@ write a function with a single use of the attribute, and then call that function from multiple places. @node Attribute VADS_Size,Attribute Value_Size,Attribute Valid_Scalars,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1c6} +@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1c9} @section Attribute VADS_Size @@ -12419,7 +12448,7 @@ gives the result that would be obtained by applying the attribute to the corresponding type. @node Attribute Value_Size,Attribute Wchar_T_Size,Attribute VADS_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{174}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1c7} +@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{177}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1ca} @section Attribute Value_Size @@ -12433,7 +12462,7 @@ a value of the given subtype. It is the same as @code{type'Size}, but, unlike @code{Size}, may be set for non-first subtypes. @node Attribute Wchar_T_Size,Attribute Word_Size,Attribute Value_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1c8} +@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1cb} @section Attribute Wchar_T_Size @@ -12445,7 +12474,7 @@ primarily for constructing the definition of this type in package @code{Interfaces.C}. The result is a static constant. @node Attribute Word_Size,,Attribute Wchar_T_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1c9} +@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1cc} @section Attribute Word_Size @@ -12456,7 +12485,7 @@ prefix) provides the value @code{System.Word_Size}. The result is a static constant. @node Standard and Implementation Defined Restrictions,Implementation Advice,Implementation Defined Attributes,Top -@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1ca}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1cb}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1cd}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1ce}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9} @chapter Standard and Implementation Defined Restrictions @@ -12485,7 +12514,7 @@ language defined or GNAT-specific, are listed in the following. @end menu @node Partition-Wide Restrictions,Program Unit Level Restrictions,,Standard and Implementation Defined Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1cc}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1cd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1cf}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1d0} @section Partition-Wide Restrictions @@ -12578,7 +12607,7 @@ then all compilation units in the partition must obey the restriction). @end menu @node Immediate_Reclamation,Max_Asynchronous_Select_Nesting,,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1ce} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1d1} @subsection Immediate_Reclamation @@ -12590,7 +12619,7 @@ deallocation, any storage reserved at run time for an object is immediately reclaimed when the object no longer exists. @node Max_Asynchronous_Select_Nesting,Max_Entry_Queue_Length,Immediate_Reclamation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1cf} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1d2} @subsection Max_Asynchronous_Select_Nesting @@ -12602,7 +12631,7 @@ detected at compile time. Violations of this restriction with values other than zero cause Storage_Error to be raised. @node Max_Entry_Queue_Length,Max_Protected_Entries,Max_Asynchronous_Select_Nesting,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1d0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1d3} @subsection Max_Entry_Queue_Length @@ -12623,7 +12652,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node Max_Protected_Entries,Max_Select_Alternatives,Max_Entry_Queue_Length,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1d1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1d4} @subsection Max_Protected_Entries @@ -12634,7 +12663,7 @@ bounds of every entry family of a protected unit shall be static, or shall be defined by a discriminant of a subtype whose corresponding bound is static. @node Max_Select_Alternatives,Max_Storage_At_Blocking,Max_Protected_Entries,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1d2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1d5} @subsection Max_Select_Alternatives @@ -12643,7 +12672,7 @@ defined by a discriminant of a subtype whose corresponding bound is static. [RM D.7] Specifies the maximum number of alternatives in a selective accept. @node Max_Storage_At_Blocking,Max_Task_Entries,Max_Select_Alternatives,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1d3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1d6} @subsection Max_Storage_At_Blocking @@ -12654,7 +12683,7 @@ Storage_Size that can be retained by a blocked task. A violation of this restriction causes Storage_Error to be raised. @node Max_Task_Entries,Max_Tasks,Max_Storage_At_Blocking,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1d4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1d7} @subsection Max_Task_Entries @@ -12667,7 +12696,7 @@ defined by a discriminant of a subtype whose corresponding bound is static. @node Max_Tasks,No_Abort_Statements,Max_Task_Entries,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1d5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1d8} @subsection Max_Tasks @@ -12680,7 +12709,7 @@ time. Violations of this restriction with values other than zero cause Storage_Error to be raised. @node No_Abort_Statements,No_Access_Parameter_Allocators,Max_Tasks,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1d6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1d9} @subsection No_Abort_Statements @@ -12690,7 +12719,7 @@ Storage_Error to be raised. no calls to Task_Identification.Abort_Task. @node No_Access_Parameter_Allocators,No_Access_Subprograms,No_Abort_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1d7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1da} @subsection No_Access_Parameter_Allocators @@ -12701,7 +12730,7 @@ occurrences of an allocator as the actual parameter to an access parameter. @node No_Access_Subprograms,No_Allocators,No_Access_Parameter_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1d8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1db} @subsection No_Access_Subprograms @@ -12711,7 +12740,7 @@ parameter. declarations of access-to-subprogram types. @node No_Allocators,No_Anonymous_Allocators,No_Access_Subprograms,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1d9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1dc} @subsection No_Allocators @@ -12721,7 +12750,7 @@ declarations of access-to-subprogram types. occurrences of an allocator. @node No_Anonymous_Allocators,No_Asynchronous_Control,No_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1da} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1dd} @subsection No_Anonymous_Allocators @@ -12731,7 +12760,7 @@ occurrences of an allocator. occurrences of an allocator of anonymous access type. @node No_Asynchronous_Control,No_Calendar,No_Anonymous_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1db} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1de} @subsection No_Asynchronous_Control @@ -12741,7 +12770,7 @@ occurrences of an allocator of anonymous access type. dependences on the predefined package Asynchronous_Task_Control. @node No_Calendar,No_Coextensions,No_Asynchronous_Control,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1dc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1df} @subsection No_Calendar @@ -12751,7 +12780,7 @@ dependences on the predefined package Asynchronous_Task_Control. dependences on package Calendar. @node No_Coextensions,No_Default_Initialization,No_Calendar,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1dd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1e0} @subsection No_Coextensions @@ -12761,7 +12790,7 @@ dependences on package Calendar. coextensions. See 3.10.2. @node No_Default_Initialization,No_Delay,No_Coextensions,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1de} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1e1} @subsection No_Default_Initialization @@ -12778,7 +12807,7 @@ is to prohibit all cases of variables declared without a specific initializer (including the case of OUT scalar parameters). @node No_Delay,No_Dependence,No_Default_Initialization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1df} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1e2} @subsection No_Delay @@ -12788,7 +12817,7 @@ initializer (including the case of OUT scalar parameters). delay statements and no semantic dependences on package Calendar. @node No_Dependence,No_Direct_Boolean_Operators,No_Delay,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1e0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1e3} @subsection No_Dependence @@ -12831,7 +12860,7 @@ to support specific constructs of the language. Here are some examples: @end itemize @node No_Direct_Boolean_Operators,No_Dispatch,No_Dependence,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1e1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1e4} @subsection No_Direct_Boolean_Operators @@ -12844,7 +12873,7 @@ protocol requires the use of short-circuit (and then, or else) forms for all composite boolean operations. @node No_Dispatch,No_Dispatching_Calls,No_Direct_Boolean_Operators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1e2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1e5} @subsection No_Dispatch @@ -12854,7 +12883,7 @@ composite boolean operations. occurrences of @code{T'Class}, for any (tagged) subtype @code{T}. @node No_Dispatching_Calls,No_Dynamic_Attachment,No_Dispatch,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1e3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1e6} @subsection No_Dispatching_Calls @@ -12915,7 +12944,7 @@ end Example; @end example @node No_Dynamic_Attachment,No_Dynamic_Priorities,No_Dispatching_Calls,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1e4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1e7} @subsection No_Dynamic_Attachment @@ -12934,7 +12963,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node No_Dynamic_Priorities,No_Entry_Calls_In_Elaboration_Code,No_Dynamic_Attachment,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1e5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1e8} @subsection No_Dynamic_Priorities @@ -12943,7 +12972,7 @@ warnings on obsolescent features are activated). [RM D.7] There are no semantic dependencies on the package Dynamic_Priorities. @node No_Entry_Calls_In_Elaboration_Code,No_Enumeration_Maps,No_Dynamic_Priorities,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1e6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1e9} @subsection No_Entry_Calls_In_Elaboration_Code @@ -12955,7 +12984,7 @@ restriction, the compiler can assume that no code past an accept statement in a task can be executed at elaboration time. @node No_Enumeration_Maps,No_Exception_Handlers,No_Entry_Calls_In_Elaboration_Code,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1e7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1ea} @subsection No_Enumeration_Maps @@ -12966,7 +12995,7 @@ enumeration maps are used (that is Image and Value attributes applied to enumeration types). @node No_Exception_Handlers,No_Exception_Propagation,No_Enumeration_Maps,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1e8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1eb} @subsection No_Exception_Handlers @@ -12991,7 +13020,7 @@ statement generated by the compiler). The Line parameter when nonzero represents the line number in the source program where the raise occurs. @node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1e9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1ec} @subsection No_Exception_Propagation @@ -13008,7 +13037,7 @@ the package GNAT.Current_Exception is not permitted, and reraise statements (raise with no operand) are not permitted. @node No_Exception_Registration,No_Exceptions,No_Exception_Propagation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1ea} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1ed} @subsection No_Exception_Registration @@ -13022,7 +13051,7 @@ code is simplified by omitting the otherwise-required global registration of exceptions when they are declared. @node No_Exceptions,No_Finalization,No_Exception_Registration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1eb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1ee} @subsection No_Exceptions @@ -13033,7 +13062,7 @@ raise statements and no exception handlers and also suppresses the generation of language-defined run-time checks. @node No_Finalization,No_Fixed_Point,No_Exceptions,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1ec} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1ef} @subsection No_Finalization @@ -13074,7 +13103,7 @@ object or a nested component, either declared on the stack or on the heap. The deallocation of a controlled object no longer finalizes its contents. @node No_Fixed_Point,No_Floating_Point,No_Finalization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1ed} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1f0} @subsection No_Fixed_Point @@ -13084,7 +13113,7 @@ deallocation of a controlled object no longer finalizes its contents. occurrences of fixed point types and operations. @node No_Floating_Point,No_Implicit_Conditionals,No_Fixed_Point,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1ee} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1f1} @subsection No_Floating_Point @@ -13094,7 +13123,7 @@ occurrences of fixed point types and operations. occurrences of floating point types and operations. @node No_Implicit_Conditionals,No_Implicit_Dynamic_Code,No_Floating_Point,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1ef} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1f2} @subsection No_Implicit_Conditionals @@ -13110,7 +13139,7 @@ normal manner. Constructs generating implicit conditionals include comparisons of composite objects and the Max/Min attributes. @node No_Implicit_Dynamic_Code,No_Implicit_Heap_Allocations,No_Implicit_Conditionals,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1f0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1f3} @subsection No_Implicit_Dynamic_Code @@ -13140,7 +13169,7 @@ foreign-language convention; primitive operations of nested tagged types. @node No_Implicit_Heap_Allocations,No_Implicit_Protected_Object_Allocations,No_Implicit_Dynamic_Code,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1f1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1f4} @subsection No_Implicit_Heap_Allocations @@ -13149,7 +13178,7 @@ types. [RM D.7] No constructs are allowed to cause implicit heap allocation. @node No_Implicit_Protected_Object_Allocations,No_Implicit_Task_Allocations,No_Implicit_Heap_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1f2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1f5} @subsection No_Implicit_Protected_Object_Allocations @@ -13159,7 +13188,7 @@ types. protected object. @node No_Implicit_Task_Allocations,No_Initialize_Scalars,No_Implicit_Protected_Object_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1f3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1f6} @subsection No_Implicit_Task_Allocations @@ -13168,7 +13197,7 @@ protected object. [GNAT] No constructs are allowed to cause implicit heap allocation of a task. @node No_Initialize_Scalars,No_IO,No_Implicit_Task_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1f4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1f7} @subsection No_Initialize_Scalars @@ -13180,7 +13209,7 @@ code, and in particular eliminates dummy null initialization routines that are otherwise generated for some record and array types. @node No_IO,No_Local_Allocators,No_Initialize_Scalars,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1f5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1f8} @subsection No_IO @@ -13191,7 +13220,7 @@ dependences on any of the library units Sequential_IO, Direct_IO, Text_IO, Wide_Text_IO, Wide_Wide_Text_IO, or Stream_IO. @node No_Local_Allocators,No_Local_Protected_Objects,No_IO,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1f6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1f9} @subsection No_Local_Allocators @@ -13202,7 +13231,7 @@ occurrences of an allocator in subprograms, generic subprograms, tasks, and entry bodies. @node No_Local_Protected_Objects,No_Local_Tagged_Types,No_Local_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1f7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1fa} @subsection No_Local_Protected_Objects @@ -13212,7 +13241,7 @@ and entry bodies. only declared at the library level. @node No_Local_Tagged_Types,No_Local_Timing_Events,No_Local_Protected_Objects,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-tagged-types}@anchor{1f8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-tagged-types}@anchor{1fb} @subsection No_Local_Tagged_Types @@ -13222,7 +13251,7 @@ only declared at the library level. declared at the library level. @node No_Local_Timing_Events,No_Long_Long_Integers,No_Local_Tagged_Types,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1f9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1fc} @subsection No_Local_Timing_Events @@ -13232,7 +13261,7 @@ declared at the library level. declared at the library level. @node No_Long_Long_Integers,No_Multiple_Elaboration,No_Local_Timing_Events,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1fa} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1fd} @subsection No_Long_Long_Integers @@ -13244,7 +13273,7 @@ implicit base type is Long_Long_Integer, and modular types whose size exceeds Long_Integer’Size. @node No_Multiple_Elaboration,No_Nested_Finalization,No_Long_Long_Integers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1fb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1fe} @subsection No_Multiple_Elaboration @@ -13260,7 +13289,7 @@ possible, including non-Ada main programs and Stand Alone libraries, are not permitted and will be diagnosed by the binder. @node No_Nested_Finalization,No_Protected_Type_Allocators,No_Multiple_Elaboration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1fc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1ff} @subsection No_Nested_Finalization @@ -13269,7 +13298,7 @@ permitted and will be diagnosed by the binder. [RM D.7] All objects requiring finalization are declared at the library level. @node No_Protected_Type_Allocators,No_Protected_Types,No_Nested_Finalization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1fd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{200} @subsection No_Protected_Type_Allocators @@ -13279,7 +13308,7 @@ permitted and will be diagnosed by the binder. expressions that attempt to allocate protected objects. @node No_Protected_Types,No_Recursion,No_Protected_Type_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1fe} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{201} @subsection No_Protected_Types @@ -13289,7 +13318,7 @@ expressions that attempt to allocate protected objects. declarations of protected types or protected objects. @node No_Recursion,No_Reentrancy,No_Protected_Types,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1ff} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{202} @subsection No_Recursion @@ -13299,7 +13328,7 @@ declarations of protected types or protected objects. part of its execution. @node No_Reentrancy,No_Relative_Delay,No_Recursion,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{200} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{203} @subsection No_Reentrancy @@ -13309,7 +13338,7 @@ part of its execution. two tasks at the same time. @node No_Relative_Delay,No_Requeue_Statements,No_Reentrancy,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{201} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{204} @subsection No_Relative_Delay @@ -13320,7 +13349,7 @@ relative statements and prevents expressions such as @code{delay 1.23;} from appearing in source code. @node No_Requeue_Statements,No_Secondary_Stack,No_Relative_Delay,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{202} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{205} @subsection No_Requeue_Statements @@ -13338,7 +13367,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on oNobsolescent features are activated). @node No_Secondary_Stack,No_Select_Statements,No_Requeue_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{203} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{206} @subsection No_Secondary_Stack @@ -13351,7 +13380,7 @@ stack is used to implement functions returning unconstrained objects secondary stacks for tasks (excluding the environment task) at run time. @node No_Select_Statements,No_Specific_Termination_Handlers,No_Secondary_Stack,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{204} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{207} @subsection No_Select_Statements @@ -13361,7 +13390,7 @@ secondary stacks for tasks (excluding the environment task) at run time. kind are permitted, that is the keyword @code{select} may not appear. @node No_Specific_Termination_Handlers,No_Specification_of_Aspect,No_Select_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{205} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{208} @subsection No_Specific_Termination_Handlers @@ -13371,7 +13400,7 @@ kind are permitted, that is the keyword @code{select} may not appear. or to Ada.Task_Termination.Specific_Handler. @node No_Specification_of_Aspect,No_Standard_Allocators_After_Elaboration,No_Specific_Termination_Handlers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{206} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{209} @subsection No_Specification_of_Aspect @@ -13382,7 +13411,7 @@ specification, attribute definition clause, or pragma is given for a given aspect. @node No_Standard_Allocators_After_Elaboration,No_Standard_Storage_Pools,No_Specification_of_Aspect,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{207} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{20a} @subsection No_Standard_Allocators_After_Elaboration @@ -13394,7 +13423,7 @@ library items of the partition has completed. Otherwise, Storage_Error is raised. @node No_Standard_Storage_Pools,No_Stream_Optimizations,No_Standard_Allocators_After_Elaboration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{208} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{20b} @subsection No_Standard_Storage_Pools @@ -13406,7 +13435,7 @@ have an explicit Storage_Pool attribute defined specifying a user-defined storage pool. @node No_Stream_Optimizations,No_Streams,No_Standard_Storage_Pools,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{209} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{20c} @subsection No_Stream_Optimizations @@ -13419,7 +13448,7 @@ due to their superior performance. When this restriction is in effect, the compiler performs all IO operations on a per-character basis. @node No_Streams,No_Tagged_Type_Registration,No_Stream_Optimizations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{20a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{20d} @subsection No_Streams @@ -13446,7 +13475,7 @@ configuration pragmas to avoid exposing entity names at binary level for the entire partition. @node No_Tagged_Type_Registration,No_Task_Allocators,No_Streams,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tagged-type-registration}@anchor{20b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tagged-type-registration}@anchor{20e} @subsection No_Tagged_Type_Registration @@ -13461,7 +13490,7 @@ are declared. This restriction may be necessary in order to also apply the No_Elaboration_Code restriction. @node No_Task_Allocators,No_Task_At_Interrupt_Priority,No_Tagged_Type_Registration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{20c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{20f} @subsection No_Task_Allocators @@ -13471,7 +13500,7 @@ the No_Elaboration_Code restriction. or types containing task subcomponents. @node No_Task_At_Interrupt_Priority,No_Task_Attributes_Package,No_Task_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{20d} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{210} @subsection No_Task_At_Interrupt_Priority @@ -13483,7 +13512,7 @@ a consequence, the tasks are always created with a priority below that an interrupt priority. @node No_Task_Attributes_Package,No_Task_Hierarchy,No_Task_At_Interrupt_Priority,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{20e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{211} @subsection No_Task_Attributes_Package @@ -13500,7 +13529,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node No_Task_Hierarchy,No_Task_Termination,No_Task_Attributes_Package,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{20f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{212} @subsection No_Task_Hierarchy @@ -13510,7 +13539,7 @@ warnings on obsolescent features are activated). directly on the environment task of the partition. @node No_Task_Termination,No_Tasking,No_Task_Hierarchy,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{210} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{213} @subsection No_Task_Termination @@ -13519,7 +13548,7 @@ directly on the environment task of the partition. [RM D.7] Tasks that terminate are erroneous. @node No_Tasking,No_Terminate_Alternatives,No_Task_Termination,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{211} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{214} @subsection No_Tasking @@ -13532,7 +13561,7 @@ and cause an error message to be output either by the compiler or binder. @node No_Terminate_Alternatives,No_Unchecked_Access,No_Tasking,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{212} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{215} @subsection No_Terminate_Alternatives @@ -13541,7 +13570,7 @@ binder. [RM D.7] There are no selective accepts with terminate alternatives. @node No_Unchecked_Access,No_Unchecked_Conversion,No_Terminate_Alternatives,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{213} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{216} @subsection No_Unchecked_Access @@ -13551,7 +13580,7 @@ binder. occurrences of the Unchecked_Access attribute. @node No_Unchecked_Conversion,No_Unchecked_Deallocation,No_Unchecked_Access,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{214} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{217} @subsection No_Unchecked_Conversion @@ -13561,7 +13590,7 @@ occurrences of the Unchecked_Access attribute. dependences on the predefined generic function Unchecked_Conversion. @node No_Unchecked_Deallocation,No_Use_Of_Attribute,No_Unchecked_Conversion,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{215} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{218} @subsection No_Unchecked_Deallocation @@ -13571,7 +13600,7 @@ dependences on the predefined generic function Unchecked_Conversion. dependences on the predefined generic procedure Unchecked_Deallocation. @node No_Use_Of_Attribute,No_Use_Of_Entity,No_Unchecked_Deallocation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-attribute}@anchor{216} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-attribute}@anchor{219} @subsection No_Use_Of_Attribute @@ -13581,7 +13610,7 @@ dependences on the predefined generic procedure Unchecked_Deallocation. earlier versions of Ada. @node No_Use_Of_Entity,No_Use_Of_Pragma,No_Use_Of_Attribute,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{217} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{21a} @subsection No_Use_Of_Entity @@ -13601,7 +13630,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line @end example @node No_Use_Of_Pragma,Pure_Barriers,No_Use_Of_Entity,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-pragma}@anchor{218} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-pragma}@anchor{21b} @subsection No_Use_Of_Pragma @@ -13611,7 +13640,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line earlier versions of Ada. @node Pure_Barriers,Simple_Barriers,No_Use_Of_Pragma,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{219} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{21c} @subsection Pure_Barriers @@ -13662,7 +13691,7 @@ but still ensures absence of side effects, exceptions, and recursion during the evaluation of the barriers. @node Simple_Barriers,Static_Priorities,Pure_Barriers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{21a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{21d} @subsection Simple_Barriers @@ -13681,7 +13710,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node Static_Priorities,Static_Storage_Size,Simple_Barriers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{21b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{21e} @subsection Static_Priorities @@ -13692,7 +13721,7 @@ are static, and that there are no dependences on the package @code{Ada.Dynamic_Priorities}. @node Static_Storage_Size,,Static_Priorities,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{21c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{21f} @subsection Static_Storage_Size @@ -13702,7 +13731,7 @@ are static, and that there are no dependences on the package in a Storage_Size pragma or attribute definition clause is static. @node Program Unit Level Restrictions,,Partition-Wide Restrictions,Standard and Implementation Defined Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{21d}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{21e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{220}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{221} @section Program Unit Level Restrictions @@ -13733,7 +13762,7 @@ other compilation units in the partition. @end menu @node No_Elaboration_Code,No_Dynamic_Accessibility_Checks,,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{21f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{222} @subsection No_Elaboration_Code @@ -13789,7 +13818,7 @@ associated with the unit. This counter is typically used to check for access before elaboration and to control multiple elaboration attempts. @node No_Dynamic_Accessibility_Checks,No_Dynamic_Sized_Objects,No_Elaboration_Code,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-accessibility-checks}@anchor{220} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-accessibility-checks}@anchor{223} @subsection No_Dynamic_Accessibility_Checks @@ -13838,7 +13867,7 @@ In all other cases, the level of T is as defined by the existing rules of Ada. @end itemize @node No_Dynamic_Sized_Objects,No_Entry_Queue,No_Dynamic_Accessibility_Checks,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{221} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{224} @subsection No_Dynamic_Sized_Objects @@ -13856,7 +13885,7 @@ access discriminants. It is often a good idea to combine this restriction with No_Secondary_Stack. @node No_Entry_Queue,No_Implementation_Aspect_Specifications,No_Dynamic_Sized_Objects,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{222} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{225} @subsection No_Entry_Queue @@ -13869,7 +13898,7 @@ checked at compile time. A program execution is erroneous if an attempt is made to queue a second task on such an entry. @node No_Implementation_Aspect_Specifications,No_Implementation_Attributes,No_Entry_Queue,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{223} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{226} @subsection No_Implementation_Aspect_Specifications @@ -13880,7 +13909,7 @@ GNAT-defined aspects are present. With this restriction, the only aspects that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Attributes,No_Implementation_Identifiers,No_Implementation_Aspect_Specifications,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{224} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{227} @subsection No_Implementation_Attributes @@ -13892,7 +13921,7 @@ attributes that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Identifiers,No_Implementation_Pragmas,No_Implementation_Attributes,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{225} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{228} @subsection No_Implementation_Identifiers @@ -13903,7 +13932,7 @@ implementation-defined identifiers (marked with pragma Implementation_Defined) occur within language-defined packages. @node No_Implementation_Pragmas,No_Implementation_Restrictions,No_Implementation_Identifiers,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{226} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{229} @subsection No_Implementation_Pragmas @@ -13914,7 +13943,7 @@ GNAT-defined pragmas are present. With this restriction, the only pragmas that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Restrictions,No_Implementation_Units,No_Implementation_Pragmas,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{227} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{22a} @subsection No_Implementation_Restrictions @@ -13926,7 +13955,7 @@ are present. With this restriction, the only other restriction identifiers that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Units,No_Implicit_Aliasing,No_Implementation_Restrictions,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{228} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{22b} @subsection No_Implementation_Units @@ -13937,7 +13966,7 @@ mention in the context clause of any implementation-defined descendants of packages Ada, Interfaces, or System. @node No_Implicit_Aliasing,No_Implicit_Loops,No_Implementation_Units,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{229} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{22c} @subsection No_Implicit_Aliasing @@ -13952,7 +13981,7 @@ to be aliased, and in such cases, it can always be replaced by the standard attribute Unchecked_Access which is preferable. @node No_Implicit_Loops,No_Obsolescent_Features,No_Implicit_Aliasing,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{22a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{22d} @subsection No_Implicit_Loops @@ -13969,7 +13998,7 @@ arrays larger than about 5000 scalar components. Note that if this restriction is set in the spec of a package, it will not apply to its body. @node No_Obsolescent_Features,No_Wide_Characters,No_Implicit_Loops,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{22b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{22e} @subsection No_Obsolescent_Features @@ -13979,7 +14008,7 @@ is set in the spec of a package, it will not apply to its body. features are used, as defined in Annex J of the Ada Reference Manual. @node No_Wide_Characters,Static_Dispatch_Tables,No_Obsolescent_Features,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{22c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{22f} @subsection No_Wide_Characters @@ -13993,7 +14022,7 @@ appear in the program (that is literals representing characters not in type @code{Character}). @node Static_Dispatch_Tables,SPARK_05,No_Wide_Characters,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{22d} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{230} @subsection Static_Dispatch_Tables @@ -14003,7 +14032,7 @@ type @code{Character}). associated with dispatch tables can be placed in read-only memory. @node SPARK_05,,Static_Dispatch_Tables,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{22e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{231} @subsection SPARK_05 @@ -14026,7 +14055,7 @@ gnatprove -P project.gpr --mode=check_all @end example @node Implementation Advice,Implementation Defined Characteristics,Standard and Implementation Defined Restrictions,Top -@anchor{gnat_rm/implementation_advice doc}@anchor{22f}@anchor{gnat_rm/implementation_advice id1}@anchor{230}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a} +@anchor{gnat_rm/implementation_advice doc}@anchor{232}@anchor{gnat_rm/implementation_advice id1}@anchor{233}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a} @chapter Implementation Advice @@ -14124,7 +14153,7 @@ case the text describes what GNAT does and why. @end menu @node RM 1 1 3 20 Error Detection,RM 1 1 3 31 Child Units,,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{231} +@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{234} @section RM 1.1.3(20): Error Detection @@ -14141,7 +14170,7 @@ or diagnosed at compile time. @geindex Child Units @node RM 1 1 3 31 Child Units,RM 1 1 5 12 Bounded Errors,RM 1 1 3 20 Error Detection,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{232} +@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{235} @section RM 1.1.3(31): Child Units @@ -14157,7 +14186,7 @@ Followed. @geindex Bounded errors @node RM 1 1 5 12 Bounded Errors,RM 2 8 16 Pragmas,RM 1 1 3 31 Child Units,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{233} +@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{236} @section RM 1.1.5(12): Bounded Errors @@ -14174,7 +14203,7 @@ runtime. @geindex Pragmas @node RM 2 8 16 Pragmas,RM 2 8 17-19 Pragmas,RM 1 1 5 12 Bounded Errors,Implementation Advice -@anchor{gnat_rm/implementation_advice id2}@anchor{234}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{235} +@anchor{gnat_rm/implementation_advice id2}@anchor{237}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{238} @section RM 2.8(16): Pragmas @@ -14287,7 +14316,7 @@ that this advice not be followed. For details see @ref{7,,Implementation Defined Pragmas}. @node RM 2 8 17-19 Pragmas,RM 3 5 2 5 Alternative Character Sets,RM 2 8 16 Pragmas,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{236} +@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{239} @section RM 2.8(17-19): Pragmas @@ -14308,14 +14337,14 @@ replacing @code{library_items}.” @end itemize @end quotation -See @ref{235,,RM 2.8(16); Pragmas}. +See @ref{238,,RM 2.8(16); Pragmas}. @geindex Character Sets @geindex Alternative Character Sets @node RM 3 5 2 5 Alternative Character Sets,RM 3 5 4 28 Integer Types,RM 2 8 17-19 Pragmas,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{237} +@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{23a} @section RM 3.5.2(5): Alternative Character Sets @@ -14343,7 +14372,7 @@ there is no such restriction. @geindex Integer types @node RM 3 5 4 28 Integer Types,RM 3 5 4 29 Integer Types,RM 3 5 2 5 Alternative Character Sets,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{238} +@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{23b} @section RM 3.5.4(28): Integer Types @@ -14362,7 +14391,7 @@ are supported for convenient interface to C, and so that all hardware types of the machine are easily available. @node RM 3 5 4 29 Integer Types,RM 3 5 5 8 Enumeration Values,RM 3 5 4 28 Integer Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{239} +@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{23c} @section RM 3.5.4(29): Integer Types @@ -14378,7 +14407,7 @@ Followed. @geindex Enumeration values @node RM 3 5 5 8 Enumeration Values,RM 3 5 7 17 Float Types,RM 3 5 4 29 Integer Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{23a} +@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{23d} @section RM 3.5.5(8): Enumeration Values @@ -14398,7 +14427,7 @@ Followed. @geindex Float types @node RM 3 5 7 17 Float Types,RM 3 6 2 11 Multidimensional Arrays,RM 3 5 5 8 Enumeration Values,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{23b} +@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{23e} @section RM 3.5.7(17): Float Types @@ -14428,7 +14457,7 @@ is a software rather than a hardware format. @geindex multidimensional @node RM 3 6 2 11 Multidimensional Arrays,RM 9 6 30-31 Duration’Small,RM 3 5 7 17 Float Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{23c} +@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{23f} @section RM 3.6.2(11): Multidimensional Arrays @@ -14446,7 +14475,7 @@ Followed. @geindex Duration'Small @node RM 9 6 30-31 Duration’Small,RM 10 2 1 12 Consistent Representation,RM 3 6 2 11 Multidimensional Arrays,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{23d} +@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{240} @section RM 9.6(30-31): Duration’Small @@ -14467,7 +14496,7 @@ it need not be the same time base as used for @code{Calendar.Clock}.” Followed. @node RM 10 2 1 12 Consistent Representation,RM 11 4 1 19 Exception Information,RM 9 6 30-31 Duration’Small,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{23e} +@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{241} @section RM 10.2.1(12): Consistent Representation @@ -14489,7 +14518,7 @@ advice without severely impacting efficiency of execution. @geindex Exception information @node RM 11 4 1 19 Exception Information,RM 11 5 28 Suppression of Checks,RM 10 2 1 12 Consistent Representation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{23f} +@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{242} @section RM 11.4.1(19): Exception Information @@ -14520,7 +14549,7 @@ Pragma @code{Discard_Names}. @geindex suppression of @node RM 11 5 28 Suppression of Checks,RM 13 1 21-24 Representation Clauses,RM 11 4 1 19 Exception Information,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{240} +@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{243} @section RM 11.5(28): Suppression of Checks @@ -14535,7 +14564,7 @@ Followed. @geindex Representation clauses @node RM 13 1 21-24 Representation Clauses,RM 13 2 6-8 Packed Types,RM 11 5 28 Suppression of Checks,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{241} +@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{244} @section RM 13.1 (21-24): Representation Clauses @@ -14587,7 +14616,7 @@ Followed. @geindex Packed types @node RM 13 2 6-8 Packed Types,RM 13 3 14-19 Address Clauses,RM 13 1 21-24 Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{242} +@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{245} @section RM 13.2(6-8): Packed Types @@ -14618,7 +14647,7 @@ subcomponent of the packed type. @geindex Address clauses @node RM 13 3 14-19 Address Clauses,RM 13 3 29-35 Alignment Clauses,RM 13 2 6-8 Packed Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{243} +@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{246} @section RM 13.3(14-19): Address Clauses @@ -14671,7 +14700,7 @@ Followed. @geindex Alignment clauses @node RM 13 3 29-35 Alignment Clauses,RM 13 3 42-43 Size Clauses,RM 13 3 14-19 Address Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{244} +@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{247} @section RM 13.3(29-35): Alignment Clauses @@ -14728,7 +14757,7 @@ Followed. @geindex Size clauses @node RM 13 3 42-43 Size Clauses,RM 13 3 50-56 Size Clauses,RM 13 3 29-35 Alignment Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{245} +@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{248} @section RM 13.3(42-43): Size Clauses @@ -14746,7 +14775,7 @@ object’s @code{Alignment} (if the @code{Alignment} is nonzero).” Followed. @node RM 13 3 50-56 Size Clauses,RM 13 3 71-73 Component Size Clauses,RM 13 3 42-43 Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{246} +@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{249} @section RM 13.3(50-56): Size Clauses @@ -14797,7 +14826,7 @@ Followed. @geindex Component_Size clauses @node RM 13 3 71-73 Component Size Clauses,RM 13 4 9-10 Enumeration Representation Clauses,RM 13 3 50-56 Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{247} +@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{24a} @section RM 13.3(71-73): Component Size Clauses @@ -14831,7 +14860,7 @@ Followed. @geindex enumeration @node RM 13 4 9-10 Enumeration Representation Clauses,RM 13 5 1 17-22 Record Representation Clauses,RM 13 3 71-73 Component Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{248} +@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{24b} @section RM 13.4(9-10): Enumeration Representation Clauses @@ -14853,7 +14882,7 @@ Followed. @geindex records @node RM 13 5 1 17-22 Record Representation Clauses,RM 13 5 2 5 Storage Place Attributes,RM 13 4 9-10 Enumeration Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{249} +@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{24c} @section RM 13.5.1(17-22): Record Representation Clauses @@ -14913,7 +14942,7 @@ and all mentioned features are implemented. @geindex Storage place attributes @node RM 13 5 2 5 Storage Place Attributes,RM 13 5 3 7-8 Bit Ordering,RM 13 5 1 17-22 Record Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{24a} +@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{24d} @section RM 13.5.2(5): Storage Place Attributes @@ -14933,7 +14962,7 @@ Followed. There are no such components in GNAT. @geindex Bit ordering @node RM 13 5 3 7-8 Bit Ordering,RM 13 7 37 Address as Private,RM 13 5 2 5 Storage Place Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{24b} +@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{24e} @section RM 13.5.3(7-8): Bit Ordering @@ -14951,7 +14980,7 @@ Followed. @geindex as private type @node RM 13 7 37 Address as Private,RM 13 7 1 16 Address Operations,RM 13 5 3 7-8 Bit Ordering,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{24c} +@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{24f} @section RM 13.7(37): Address as Private @@ -14969,7 +14998,7 @@ Followed. @geindex operations of @node RM 13 7 1 16 Address Operations,RM 13 9 14-17 Unchecked Conversion,RM 13 7 37 Address as Private,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{24d} +@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{250} @section RM 13.7.1(16): Address Operations @@ -14987,7 +15016,7 @@ operation raises @code{Program_Error}, since all operations make sense. @geindex Unchecked conversion @node RM 13 9 14-17 Unchecked Conversion,RM 13 11 23-25 Implicit Heap Usage,RM 13 7 1 16 Address Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{24e} +@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{251} @section RM 13.9(14-17): Unchecked Conversion @@ -15031,7 +15060,7 @@ Followed. @geindex implicit @node RM 13 11 23-25 Implicit Heap Usage,RM 13 11 2 17 Unchecked Deallocation,RM 13 9 14-17 Unchecked Conversion,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{24f} +@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{252} @section RM 13.11(23-25): Implicit Heap Usage @@ -15082,7 +15111,7 @@ Followed. @geindex Unchecked deallocation @node RM 13 11 2 17 Unchecked Deallocation,RM 13 13 2 1 6 Stream Oriented Attributes,RM 13 11 23-25 Implicit Heap Usage,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{250} +@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{253} @section RM 13.11.2(17): Unchecked Deallocation @@ -15097,7 +15126,7 @@ Followed. @geindex Stream oriented attributes @node RM 13 13 2 1 6 Stream Oriented Attributes,RM A 1 52 Names of Predefined Numeric Types,RM 13 11 2 17 Unchecked Deallocation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{251} +@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{254} @section RM 13.13.2(1.6): Stream Oriented Attributes @@ -15128,7 +15157,7 @@ scalar types. This XDR alternative can be enabled via the binder switch -xdr. @geindex Stream oriented attributes @node RM A 1 52 Names of Predefined Numeric Types,RM A 3 2 49 Ada Characters Handling,RM 13 13 2 1 6 Stream Oriented Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{252} +@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{255} @section RM A.1(52): Names of Predefined Numeric Types @@ -15146,7 +15175,7 @@ Followed. @geindex Ada.Characters.Handling @node RM A 3 2 49 Ada Characters Handling,RM A 4 4 106 Bounded-Length String Handling,RM A 1 52 Names of Predefined Numeric Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{253} +@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{256} @section RM A.3.2(49): @code{Ada.Characters.Handling} @@ -15163,7 +15192,7 @@ Followed. GNAT provides no such localized definitions. @geindex Bounded-length strings @node RM A 4 4 106 Bounded-Length String Handling,RM A 5 2 46-47 Random Number Generation,RM A 3 2 49 Ada Characters Handling,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{254} +@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{257} @section RM A.4.4(106): Bounded-Length String Handling @@ -15178,7 +15207,7 @@ Followed. No implicit pointers or dynamic allocation are used. @geindex Random number generation @node RM A 5 2 46-47 Random Number Generation,RM A 10 7 23 Get_Immediate,RM A 4 4 106 Bounded-Length String Handling,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{255} +@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{258} @section RM A.5.2(46-47): Random Number Generation @@ -15207,7 +15236,7 @@ condition here to hold true. @geindex Get_Immediate @node RM A 10 7 23 Get_Immediate,RM A 18 Containers,RM A 5 2 46-47 Random Number Generation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{256} +@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{259} @section RM A.10.7(23): @code{Get_Immediate} @@ -15231,7 +15260,7 @@ this functionality. @geindex Containers @node RM A 18 Containers,RM B 1 39-41 Pragma Export,RM A 10 7 23 Get_Immediate,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{257} +@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{25a} @section RM A.18: @code{Containers} @@ -15252,7 +15281,7 @@ follow the implementation advice. @geindex Export @node RM B 1 39-41 Pragma Export,RM B 2 12-13 Package Interfaces,RM A 18 Containers,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{258} +@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{25b} @section RM B.1(39-41): Pragma @code{Export} @@ -15300,7 +15329,7 @@ Followed. @geindex Interfaces @node RM B 2 12-13 Package Interfaces,RM B 3 63-71 Interfacing with C,RM B 1 39-41 Pragma Export,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{259} +@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{25c} @section RM B.2(12-13): Package @code{Interfaces} @@ -15330,7 +15359,7 @@ Followed. GNAT provides all the packages described in this section. @geindex interfacing with @node RM B 3 63-71 Interfacing with C,RM B 4 95-98 Interfacing with COBOL,RM B 2 12-13 Package Interfaces,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{25a} +@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{25d} @section RM B.3(63-71): Interfacing with C @@ -15418,7 +15447,7 @@ Followed. @geindex interfacing with @node RM B 4 95-98 Interfacing with COBOL,RM B 5 22-26 Interfacing with Fortran,RM B 3 63-71 Interfacing with C,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{25b} +@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{25e} @section RM B.4(95-98): Interfacing with COBOL @@ -15459,7 +15488,7 @@ Followed. @geindex interfacing with @node RM B 5 22-26 Interfacing with Fortran,RM C 1 3-5 Access to Machine Operations,RM B 4 95-98 Interfacing with COBOL,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{25c} +@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{25f} @section RM B.5(22-26): Interfacing with Fortran @@ -15510,7 +15539,7 @@ Followed. @geindex Machine operations @node RM C 1 3-5 Access to Machine Operations,RM C 1 10-16 Access to Machine Operations,RM B 5 22-26 Interfacing with Fortran,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{25d} +@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{260} @section RM C.1(3-5): Access to Machine Operations @@ -15545,7 +15574,7 @@ object that is specified as exported.” Followed. @node RM C 1 10-16 Access to Machine Operations,RM C 3 28 Interrupt Support,RM C 1 3-5 Access to Machine Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{25e} +@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{261} @section RM C.1(10-16): Access to Machine Operations @@ -15606,7 +15635,7 @@ Followed on any target supporting such operations. @geindex Interrupt support @node RM C 3 28 Interrupt Support,RM C 3 1 20-21 Protected Procedure Handlers,RM C 1 10-16 Access to Machine Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{25f} +@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{262} @section RM C.3(28): Interrupt Support @@ -15624,7 +15653,7 @@ of interrupt blocking. @geindex Protected procedure handlers @node RM C 3 1 20-21 Protected Procedure Handlers,RM C 3 2 25 Package Interrupts,RM C 3 28 Interrupt Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{260} +@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{263} @section RM C.3.1(20-21): Protected Procedure Handlers @@ -15650,7 +15679,7 @@ Followed. Compile time warnings are given when possible. @geindex Interrupts @node RM C 3 2 25 Package Interrupts,RM C 4 14 Pre-elaboration Requirements,RM C 3 1 20-21 Protected Procedure Handlers,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{261} +@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{264} @section RM C.3.2(25): Package @code{Interrupts} @@ -15668,7 +15697,7 @@ Followed. @geindex Pre-elaboration requirements @node RM C 4 14 Pre-elaboration Requirements,RM C 5 8 Pragma Discard_Names,RM C 3 2 25 Package Interrupts,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{262} +@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{265} @section RM C.4(14): Pre-elaboration Requirements @@ -15684,7 +15713,7 @@ Followed. Executable code is generated in some cases, e.g., loops to initialize large arrays. @node RM C 5 8 Pragma Discard_Names,RM C 7 2 30 The Package Task_Attributes,RM C 4 14 Pre-elaboration Requirements,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{263} +@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{266} @section RM C.5(8): Pragma @code{Discard_Names} @@ -15702,7 +15731,7 @@ Followed. @geindex Task_Attributes @node RM C 7 2 30 The Package Task_Attributes,RM D 3 17 Locking Policies,RM C 5 8 Pragma Discard_Names,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{264} +@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{267} @section RM C.7.2(30): The Package Task_Attributes @@ -15723,7 +15752,7 @@ Not followed. This implementation is not targeted to such a domain. @geindex Locking Policies @node RM D 3 17 Locking Policies,RM D 4 16 Entry Queuing Policies,RM C 7 2 30 The Package Task_Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{265} +@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{268} @section RM D.3(17): Locking Policies @@ -15740,7 +15769,7 @@ whose names (@code{Inheritance_Locking} and @geindex Entry queuing policies @node RM D 4 16 Entry Queuing Policies,RM D 6 9-10 Preemptive Abort,RM D 3 17 Locking Policies,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{266} +@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{269} @section RM D.4(16): Entry Queuing Policies @@ -15755,7 +15784,7 @@ Followed. No such implementation-defined queuing policies exist. @geindex Preemptive abort @node RM D 6 9-10 Preemptive Abort,RM D 7 21 Tasking Restrictions,RM D 4 16 Entry Queuing Policies,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{267} +@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{26a} @section RM D.6(9-10): Preemptive Abort @@ -15781,7 +15810,7 @@ Followed. @geindex Tasking restrictions @node RM D 7 21 Tasking Restrictions,RM D 8 47-49 Monotonic Time,RM D 6 9-10 Preemptive Abort,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{268} +@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{26b} @section RM D.7(21): Tasking Restrictions @@ -15800,7 +15829,7 @@ pragma @code{Profile (Restricted)} for more details. @geindex monotonic @node RM D 8 47-49 Monotonic Time,RM E 5 28-29 Partition Communication Subsystem,RM D 7 21 Tasking Restrictions,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{269} +@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{26c} @section RM D.8(47-49): Monotonic Time @@ -15835,7 +15864,7 @@ Followed. @geindex PCS @node RM E 5 28-29 Partition Communication Subsystem,RM F 7 COBOL Support,RM D 8 47-49 Monotonic Time,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{26a} +@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{26d} @section RM E.5(28-29): Partition Communication Subsystem @@ -15863,7 +15892,7 @@ GNAT. @geindex COBOL support @node RM F 7 COBOL Support,RM F 1 2 Decimal Radix Support,RM E 5 28-29 Partition Communication Subsystem,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{26b} +@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{26e} @section RM F(7): COBOL Support @@ -15883,7 +15912,7 @@ Followed. @geindex Decimal radix support @node RM F 1 2 Decimal Radix Support,RM G Numerics,RM F 7 COBOL Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{26c} +@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{26f} @section RM F.1(2): Decimal Radix Support @@ -15899,7 +15928,7 @@ representations. @geindex Numerics @node RM G Numerics,RM G 1 1 56-58 Complex Types,RM F 1 2 Decimal Radix Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{26d} +@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{270} @section RM G: Numerics @@ -15919,7 +15948,7 @@ Followed. @geindex Complex types @node RM G 1 1 56-58 Complex Types,RM G 1 2 49 Complex Elementary Functions,RM G Numerics,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{26e} +@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{271} @section RM G.1.1(56-58): Complex Types @@ -15981,7 +16010,7 @@ Followed. @geindex Complex elementary functions @node RM G 1 2 49 Complex Elementary Functions,RM G 2 4 19 Accuracy Requirements,RM G 1 1 56-58 Complex Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{26f} +@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{272} @section RM G.1.2(49): Complex Elementary Functions @@ -16003,7 +16032,7 @@ Followed. @geindex Accuracy requirements @node RM G 2 4 19 Accuracy Requirements,RM G 2 6 15 Complex Arithmetic Accuracy,RM G 1 2 49 Complex Elementary Functions,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{270} +@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{273} @section RM G.2.4(19): Accuracy Requirements @@ -16027,7 +16056,7 @@ Followed. @geindex complex arithmetic @node RM G 2 6 15 Complex Arithmetic Accuracy,RM H 6 15/2 Pragma Partition_Elaboration_Policy,RM G 2 4 19 Accuracy Requirements,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{271} +@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{274} @section RM G.2.6(15): Complex Arithmetic Accuracy @@ -16045,7 +16074,7 @@ Followed. @geindex Sequential elaboration policy @node RM H 6 15/2 Pragma Partition_Elaboration_Policy,,RM G 2 6 15 Complex Arithmetic Accuracy,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{272} +@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{275} @section RM H.6(15/2): Pragma Partition_Elaboration_Policy @@ -16060,7 +16089,7 @@ immediately terminated.” Not followed. @node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top -@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{273}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{274}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b} +@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{276}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{277}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b} @chapter Implementation Defined Characteristics @@ -16910,7 +16939,7 @@ See separate section on data representations. such aspects and the legality rules for such aspects. See 13.1.1(38).” @end itemize -See @ref{12e,,Implementation Defined Aspects}. +See @ref{130,,Implementation Defined Aspects}. @itemize * @@ -17354,7 +17383,7 @@ When the @code{Pattern} parameter is not the null string, it is interpreted according to the syntax of regular expressions as defined in the @code{GNAT.Regexp} package. -See @ref{275,,GNAT.Regexp (g-regexp.ads)}. +See @ref{278,,GNAT.Regexp (g-regexp.ads)}. @itemize * @@ -18452,7 +18481,7 @@ Information on those subjects is not yet available. Execution is erroneous in that case. @node Intrinsic Subprograms,Representation Clauses and Pragmas,Implementation Defined Characteristics,Top -@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{276}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{277}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c} +@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{279}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{27a}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c} @chapter Intrinsic Subprograms @@ -18490,7 +18519,7 @@ Ada standard does not require Ada compilers to implement this feature. @end menu @node Intrinsic Operators,Compilation_ISO_Date,,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{278}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{279} +@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{27b}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{27c} @section Intrinsic Operators @@ -18521,7 +18550,7 @@ It is also possible to specify such operators for private types, if the full views are appropriate arithmetic types. @node Compilation_ISO_Date,Compilation_Date,Intrinsic Operators,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{27a}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{27b} +@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{27d}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{27e} @section Compilation_ISO_Date @@ -18535,7 +18564,7 @@ application program should simply call the function the current compilation (in local time format YYYY-MM-DD). @node Compilation_Date,Compilation_Time,Compilation_ISO_Date,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{27c}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{27d} +@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{27f}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{280} @section Compilation_Date @@ -18545,7 +18574,7 @@ Same as Compilation_ISO_Date, except the string is in the form MMM DD YYYY. @node Compilation_Time,Enclosing_Entity,Compilation_Date,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{27e}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{27f} +@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{281}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{282} @section Compilation_Time @@ -18559,7 +18588,7 @@ application program should simply call the function the current compilation (in local time format HH:MM:SS). @node Enclosing_Entity,Exception_Information,Compilation_Time,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{280}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{281} +@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{283}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{284} @section Enclosing_Entity @@ -18573,7 +18602,7 @@ application program should simply call the function the current subprogram, package, task, entry, or protected subprogram. @node Exception_Information,Exception_Message,Enclosing_Entity,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{282}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{283} +@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{285}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{286} @section Exception_Information @@ -18587,7 +18616,7 @@ so an application program should simply call the function the exception information associated with the current exception. @node Exception_Message,Exception_Name,Exception_Information,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{284}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{285} +@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{287}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{288} @section Exception_Message @@ -18601,7 +18630,7 @@ so an application program should simply call the function the message associated with the current exception. @node Exception_Name,File,Exception_Message,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{286}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{287} +@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{289}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{28a} @section Exception_Name @@ -18615,7 +18644,7 @@ so an application program should simply call the function the name of the current exception. @node File,Line,Exception_Name,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms file}@anchor{288}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{289} +@anchor{gnat_rm/intrinsic_subprograms file}@anchor{28b}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{28c} @section File @@ -18629,7 +18658,7 @@ application program should simply call the function file. @node Line,Shifts and Rotates,File,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{28a}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{28b} +@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{28d}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{28e} @section Line @@ -18643,7 +18672,7 @@ application program should simply call the function source line. @node Shifts and Rotates,Source_Location,Line,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{28c}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{28d} +@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{28f}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{290} @section Shifts and Rotates @@ -18686,7 +18715,7 @@ corresponding operator for modular type. In particular, shifting a negative number may change its sign bit to positive. @node Source_Location,,Shifts and Rotates,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{28e}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{28f} +@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{291}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{292} @section Source_Location @@ -18700,7 +18729,7 @@ application program should simply call the function source file location. @node Representation Clauses and Pragmas,Standard Library Routines,Intrinsic Subprograms,Top -@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{290}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d} +@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{294}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d} @chapter Representation Clauses and Pragmas @@ -18746,7 +18775,7 @@ and this section describes the additional capabilities provided. @end menu @node Alignment Clauses,Size Clauses,,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{292}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{293} +@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{296} @section Alignment Clauses @@ -18768,7 +18797,7 @@ For elementary types, the alignment is the minimum of the actual size of objects of the type divided by @code{Storage_Unit}, and the maximum alignment supported by the target. (This maximum alignment is given by the GNAT-specific attribute -@code{Standard'Maximum_Alignment}; see @ref{1a2,,Attribute Maximum_Alignment}.) +@code{Standard'Maximum_Alignment}; see @ref{1a5,,Attribute Maximum_Alignment}.) @geindex Maximum_Alignment attribute @@ -18877,7 +18906,7 @@ assumption is non-portable, and other compilers may choose different alignments for the subtype @code{RS}. @node Size Clauses,Storage_Size Clauses,Alignment Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{294}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{295} +@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{298} @section Size Clauses @@ -18954,7 +18983,7 @@ if it is known that a Size value can be accommodated in an object of type Integer. @node Storage_Size Clauses,Size of Variant Record Objects,Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{296}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{297} +@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{29a} @section Storage_Size Clauses @@ -19027,7 +19056,7 @@ Of course in practice, there will not be any explicit allocators in the case of such an access declaration. @node Size of Variant Record Objects,Biased Representation,Storage_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{298}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{299} +@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{29b}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{29c} @section Size of Variant Record Objects @@ -19137,7 +19166,7 @@ the maximum size, regardless of the current variant value, the variant value. @node Biased Representation,Value_Size and Object_Size Clauses,Size of Variant Record Objects,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{29a}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{29b} +@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{29d}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{29e} @section Biased Representation @@ -19175,7 +19204,7 @@ biased representation can be used for all discrete types except for enumeration types for which a representation clause is given. @node Value_Size and Object_Size Clauses,Component_Size Clauses,Biased Representation,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{29c}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{29d} +@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{29f}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{2a0} @section Value_Size and Object_Size Clauses @@ -19491,7 +19520,7 @@ definition clause forces biased representation. This warning can be turned off using @code{-gnatw.B}. @node Component_Size Clauses,Bit_Order Clauses,Value_Size and Object_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{29e}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{29f} +@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{2a1}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{2a2} @section Component_Size Clauses @@ -19539,7 +19568,7 @@ and a pragma Pack for the same array type. if such duplicate clauses are given, the pragma Pack will be ignored. @node Bit_Order Clauses,Effect of Bit_Order on Byte Ordering,Component_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{2a0}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{2a1} +@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{2a3}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{2a4} @section Bit_Order Clauses @@ -19645,7 +19674,7 @@ if desired. The following section contains additional details regarding the issue of byte ordering. @node Effect of Bit_Order on Byte Ordering,Pragma Pack for Arrays,Bit_Order Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{2a2}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{2a3} +@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{2a5}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{2a6} @section Effect of Bit_Order on Byte Ordering @@ -19902,7 +19931,7 @@ to set the boolean constant @code{Master_Byte_First} in an appropriate manner. @node Pragma Pack for Arrays,Pragma Pack for Records,Effect of Bit_Order on Byte Ordering,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{2a4}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{2a5} +@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{2a7}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{2a8} @section Pragma Pack for Arrays @@ -20022,7 +20051,7 @@ Here 31-bit packing is achieved as required, and no warning is generated, since in this case the programmer intention is clear. @node Pragma Pack for Records,Record Representation Clauses,Pragma Pack for Arrays,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{2a6}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{2a7} +@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{2a9}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{2aa} @section Pragma Pack for Records @@ -20106,7 +20135,7 @@ array that is longer than 64 bits, so it is itself non-packable on boundary, and takes an integral number of bytes, i.e., 72 bits. @node Record Representation Clauses,Handling of Records with Holes,Pragma Pack for Records,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{2a8}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{2a9} +@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{2ab}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{2ac} @section Record Representation Clauses @@ -20185,7 +20214,7 @@ end record; @end example @node Handling of Records with Holes,Enumeration Clauses,Record Representation Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{2aa}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{2ab} +@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{2ad}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{2ae} @section Handling of Records with Holes @@ -20261,7 +20290,7 @@ for Hrec'Size use 64; @end example @node Enumeration Clauses,Address Clauses,Handling of Records with Holes,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{2ac}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{2ad} +@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{2af}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{2b0} @section Enumeration Clauses @@ -20304,7 +20333,7 @@ the overhead of converting representation values to the corresponding positional values, (i.e., the value delivered by the @code{Pos} attribute). @node Address Clauses,Use of Address Clauses for Memory-Mapped I/O,Enumeration Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{2ae}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{2af} +@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{2b1}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{2b2} @section Address Clauses @@ -20644,7 +20673,7 @@ then the program compiles without the warning and when run will generate the output @code{X was not clobbered}. @node Use of Address Clauses for Memory-Mapped I/O,Effect of Convention on Representation,Address Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{2b0}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{2b1} +@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{2b3}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{2b4} @section Use of Address Clauses for Memory-Mapped I/O @@ -20702,7 +20731,7 @@ provides the pragma @code{Volatile_Full_Access} which can be used in lieu of pragma @code{Atomic} and will give the additional guarantee. @node Effect of Convention on Representation,Conventions and Anonymous Access Types,Use of Address Clauses for Memory-Mapped I/O,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{2b2}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{2b3} +@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{2b5}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{2b6} @section Effect of Convention on Representation @@ -20716,7 +20745,7 @@ conventions, and for example records are laid out in a manner that is consistent with C. This means that specifying convention C (for example) has no effect. -There are four exceptions to this general rule: +There are three exceptions to this general rule: @itemize * @@ -20780,7 +20809,7 @@ when one of these values is read, any nonzero value is treated as True. @end itemize @node Conventions and Anonymous Access Types,Determining the Representations chosen by GNAT,Effect of Convention on Representation,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{2b4}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{2b5} +@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{2b7}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{2b8} @section Conventions and Anonymous Access Types @@ -20856,7 +20885,7 @@ package ConvComp is @end example @node Determining the Representations chosen by GNAT,,Conventions and Anonymous Access Types,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{2b6}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{2b7} +@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{2b9}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{2ba} @section Determining the Representations chosen by GNAT @@ -21008,7 +21037,7 @@ generated by the compiler into the original source to fix and guarantee the actual representation to be used. @node Standard Library Routines,The Implementation of Standard I/O,Representation Clauses and Pragmas,Top -@anchor{gnat_rm/standard_library_routines doc}@anchor{2b8}@anchor{gnat_rm/standard_library_routines id1}@anchor{2b9}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e} +@anchor{gnat_rm/standard_library_routines doc}@anchor{2bb}@anchor{gnat_rm/standard_library_routines id1}@anchor{2bc}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e} @chapter Standard Library Routines @@ -21835,7 +21864,7 @@ For packages in Interfaces and System, all the RM defined packages are available in GNAT, see the Ada 2012 RM for full details. @node The Implementation of Standard I/O,The GNAT Library,Standard Library Routines,Top -@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{2ba}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f} +@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2be}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f} @chapter The Implementation of Standard I/O @@ -21887,7 +21916,7 @@ these additional facilities are also described in this chapter. @end menu @node Standard I/O Packages,FORM Strings,,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2bc}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2bd} +@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2c0} @section Standard I/O Packages @@ -21958,7 +21987,7 @@ flush the common I/O streams and in particular Standard_Output before elaborating the Ada code. @node FORM Strings,Direct_IO,Standard I/O Packages,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2be}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2bf} +@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2c2} @section FORM Strings @@ -21984,7 +22013,7 @@ unrecognized keyword appears in a form string, it is silently ignored and not considered invalid. @node Direct_IO,Sequential_IO,FORM Strings,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2c0}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2c1} +@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2c4} @section Direct_IO @@ -22003,7 +22032,7 @@ There is no limit on the size of Direct_IO files, they are expanded as necessary to accommodate whatever records are written to the file. @node Sequential_IO,Text_IO,Direct_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2c2}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2c3} +@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2c6} @section Sequential_IO @@ -22050,7 +22079,7 @@ using Stream_IO, and this is the preferred mechanism. In particular, the above program fragment rewritten to use Stream_IO will work correctly. @node Text_IO,Wide_Text_IO,Sequential_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2c4}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2c5} +@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2c8} @section Text_IO @@ -22133,7 +22162,7 @@ the file. @end menu @node Stream Pointer Positioning,Reading and Writing Non-Regular Files,,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2c6}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2c7} +@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ca} @subsection Stream Pointer Positioning @@ -22169,7 +22198,7 @@ between two Ada files, then the difference may be observable in some situations. @node Reading and Writing Non-Regular Files,Get_Immediate,Stream Pointer Positioning,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2c8}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2c9} +@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2cc} @subsection Reading and Writing Non-Regular Files @@ -22220,7 +22249,7 @@ to read data past that end of file indication, until another end of file indication is entered. @node Get_Immediate,Treating Text_IO Files as Streams,Reading and Writing Non-Regular Files,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2ca}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2cb} +@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2ce} @subsection Get_Immediate @@ -22238,7 +22267,7 @@ possible), it is undefined whether the FF character will be treated as a page mark. @node Treating Text_IO Files as Streams,Text_IO Extensions,Get_Immediate,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2cc}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2cd} +@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2d0} @subsection Treating Text_IO Files as Streams @@ -22254,7 +22283,7 @@ skipped and the effect is similar to that described above for @code{Get_Immediate}. @node Text_IO Extensions,Text_IO Facilities for Unbounded Strings,Treating Text_IO Files as Streams,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2ce}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2cf} +@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2d1}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2d2} @subsection Text_IO Extensions @@ -22282,7 +22311,7 @@ the string is to be read. @end itemize @node Text_IO Facilities for Unbounded Strings,,Text_IO Extensions,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2d0}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2d1} +@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2d3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2d4} @subsection Text_IO Facilities for Unbounded Strings @@ -22330,7 +22359,7 @@ files @code{a-szuzti.ads} and @code{a-szuzti.adb} provides similar extended @code{Wide_Wide_Text_IO} functionality for unbounded wide wide strings. @node Wide_Text_IO,Wide_Wide_Text_IO,Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2d2}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2d3} +@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2d5}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2d6} @section Wide_Text_IO @@ -22577,12 +22606,12 @@ input also causes Constraint_Error to be raised. @end menu @node Stream Pointer Positioning<2>,Reading and Writing Non-Regular Files<2>,,Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2d4}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2d5} +@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2d7}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2d8} @subsection Stream Pointer Positioning @code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling -of stream pointer positioning (@ref{2c5,,Text_IO}). There is one additional +of stream pointer positioning (@ref{2c8,,Text_IO}). There is one additional case: If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the @@ -22601,7 +22630,7 @@ to a normal program using @code{Wide_Text_IO}. However, this discrepancy can be observed if the wide text file shares a stream with another file. @node Reading and Writing Non-Regular Files<2>,,Stream Pointer Positioning<2>,Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2d6}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2d7} +@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2d9}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2da} @subsection Reading and Writing Non-Regular Files @@ -22612,7 +22641,7 @@ treated as data characters), and @code{End_Of_Page} always returns it is possible to read beyond an end of file. @node Wide_Wide_Text_IO,Stream_IO,Wide_Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2d8}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2d9} +@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2db}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2dc} @section Wide_Wide_Text_IO @@ -22781,12 +22810,12 @@ input also causes Constraint_Error to be raised. @end menu @node Stream Pointer Positioning<3>,Reading and Writing Non-Regular Files<3>,,Wide_Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2da}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2db} +@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2dd}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2de} @subsection Stream Pointer Positioning @code{Ada.Wide_Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling -of stream pointer positioning (@ref{2c5,,Text_IO}). There is one additional +of stream pointer positioning (@ref{2c8,,Text_IO}). There is one additional case: If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the @@ -22805,7 +22834,7 @@ to a normal program using @code{Wide_Wide_Text_IO}. However, this discrepancy can be observed if the wide text file shares a stream with another file. @node Reading and Writing Non-Regular Files<3>,,Stream Pointer Positioning<3>,Wide_Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2dc}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2dd} +@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2df}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2e0} @subsection Reading and Writing Non-Regular Files @@ -22816,7 +22845,7 @@ treated as data characters), and @code{End_Of_Page} always returns it is possible to read beyond an end of file. @node Stream_IO,Text Translation,Wide_Wide_Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2de}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2df} +@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2e1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2e2} @section Stream_IO @@ -22838,7 +22867,7 @@ manner described for stream attributes. @end itemize @node Text Translation,Shared Files,Stream_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2e0}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2e1} +@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2e3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2e4} @section Text Translation @@ -22872,7 +22901,7 @@ mode. (corresponds to_O_U16TEXT). @end itemize @node Shared Files,Filenames encoding,Text Translation,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2e2}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2e3} +@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2e5}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2e6} @section Shared Files @@ -22935,7 +22964,7 @@ heterogeneous input-output. Although this approach will work in GNAT if for this purpose (using the stream attributes). @node Filenames encoding,File content encoding,Shared Files,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2e4}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2e5} +@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2e7}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2e8} @section Filenames encoding @@ -22975,7 +23004,7 @@ platform. On the other Operating Systems the run-time is supporting UTF-8 natively. @node File content encoding,Open Modes,Filenames encoding,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2e6}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2e7} +@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2e9}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ea} @section File content encoding @@ -23008,7 +23037,7 @@ Unicode 8-bit encoding This encoding is only supported on the Windows platform. @node Open Modes,Operations on C Streams,File content encoding,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2e8}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2e9} +@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2eb}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2ec} @section Open Modes @@ -23111,7 +23140,7 @@ subsequently requires switching from reading to writing or vice-versa, then the file is reopened in @code{r+} mode to permit the required operation. @node Operations on C Streams,Interfacing to C Streams,Open Modes,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2ea}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2eb} +@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2ed}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2ee} @section Operations on C Streams @@ -23271,7 +23300,7 @@ end Interfaces.C_Streams; @end example @node Interfacing to C Streams,,Operations on C Streams,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2ec}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2ed} +@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2ef}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2f0} @section Interfacing to C Streams @@ -23364,7 +23393,7 @@ imported from a C program, allowing an Ada file to operate on an existing C file. @node The GNAT Library,Interfacing to Other Languages,The Implementation of Standard I/O,Top -@anchor{gnat_rm/the_gnat_library doc}@anchor{2ee}@anchor{gnat_rm/the_gnat_library id1}@anchor{2ef}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10} +@anchor{gnat_rm/the_gnat_library doc}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id1}@anchor{2f2}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10} @chapter The GNAT Library @@ -23549,7 +23578,7 @@ of GNAT, and will generate a warning message. @end menu @node Ada Characters Latin_9 a-chlat9 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2f0}@anchor{gnat_rm/the_gnat_library id2}@anchor{2f1} +@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id2}@anchor{2f4} @section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads}) @@ -23566,7 +23595,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_1 a-cwila1 ads,Ada Characters Wide_Latin_9 a-cwila9 ads,Ada Characters Latin_9 a-chlat9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2f2}@anchor{gnat_rm/the_gnat_library id3}@anchor{2f3} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id3}@anchor{2f6} @section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads}) @@ -23583,7 +23612,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_9 a-cwila9 ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila9-ads}@anchor{2f4}@anchor{gnat_rm/the_gnat_library id4}@anchor{2f5} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila9-ads}@anchor{2f7}@anchor{gnat_rm/the_gnat_library id4}@anchor{2f8} @section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila9.ads}) @@ -23600,7 +23629,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Characters Wide_Latin_9 a-cwila9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2f6}@anchor{gnat_rm/the_gnat_library id5}@anchor{2f7} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id5}@anchor{2fa} @section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads}) @@ -23617,7 +23646,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Containers Bounded_Holders a-coboho ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2f8}@anchor{gnat_rm/the_gnat_library id6}@anchor{2f9} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id6}@anchor{2fc} @section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads}) @@ -23634,7 +23663,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2fa}@anchor{gnat_rm/the_gnat_library id7}@anchor{2fb} +@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id7}@anchor{2fe} @section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads}) @@ -23646,7 +23675,7 @@ This child of @code{Ada.Containers} defines a modified version of Indefinite_Holders that avoids heap allocation. @node Ada Command_Line Environment a-colien ads,Ada Command_Line Remove a-colire ads,Ada Containers Bounded_Holders a-coboho ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2fc}@anchor{gnat_rm/the_gnat_library id8}@anchor{2fd} +@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id8}@anchor{300} @section @code{Ada.Command_Line.Environment} (@code{a-colien.ads}) @@ -23659,7 +23688,7 @@ provides a mechanism for obtaining environment values on systems where this concept makes sense. @node Ada Command_Line Remove a-colire ads,Ada Command_Line Response_File a-clrefi ads,Ada Command_Line Environment a-colien ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2fe}@anchor{gnat_rm/the_gnat_library id9}@anchor{2ff} +@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id9}@anchor{302} @section @code{Ada.Command_Line.Remove} (@code{a-colire.ads}) @@ -23677,7 +23706,7 @@ to further calls to the subprograms in @code{Ada.Command_Line}. These calls will not see the removed argument. @node Ada Command_Line Response_File a-clrefi ads,Ada Direct_IO C_Streams a-diocst ads,Ada Command_Line Remove a-colire ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{300}@anchor{gnat_rm/the_gnat_library id10}@anchor{301} +@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id10}@anchor{304} @section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads}) @@ -23697,7 +23726,7 @@ Using a response file allow passing a set of arguments to an executable longer than the maximum allowed by the system on the command line. @node Ada Direct_IO C_Streams a-diocst ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Command_Line Response_File a-clrefi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{302}@anchor{gnat_rm/the_gnat_library id11}@anchor{303} +@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id11}@anchor{306} @section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads}) @@ -23712,7 +23741,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Direct_IO C_Streams a-diocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{304}@anchor{gnat_rm/the_gnat_library id12}@anchor{305} +@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{307}@anchor{gnat_rm/the_gnat_library id12}@anchor{308} @section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads}) @@ -23726,7 +23755,7 @@ exception occurrence (@code{Null_Occurrence}) without raising an exception. @node Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Exceptions Traceback a-exctra ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{306}@anchor{gnat_rm/the_gnat_library id13}@anchor{307} +@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{309}@anchor{gnat_rm/the_gnat_library id13}@anchor{30a} @section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads}) @@ -23740,7 +23769,7 @@ exceptions (hence the name last chance), and perform clean ups before terminating the program. Note that this subprogram never returns. @node Ada Exceptions Traceback a-exctra ads,Ada Sequential_IO C_Streams a-siocst ads,Ada Exceptions Last_Chance_Handler a-elchha ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{308}@anchor{gnat_rm/the_gnat_library id14}@anchor{309} +@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id14}@anchor{30c} @section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads}) @@ -23753,7 +23782,7 @@ give a traceback array of addresses based on an exception occurrence. @node Ada Sequential_IO C_Streams a-siocst ads,Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Exceptions Traceback a-exctra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{30a}@anchor{gnat_rm/the_gnat_library id15}@anchor{30b} +@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id15}@anchor{30e} @section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads}) @@ -23768,7 +23797,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Strings Unbounded Text_IO a-suteio ads,Ada Sequential_IO C_Streams a-siocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{30c}@anchor{gnat_rm/the_gnat_library id16}@anchor{30d} +@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id16}@anchor{310} @section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads}) @@ -23783,7 +23812,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Strings Unbounded Text_IO a-suteio ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Streams Stream_IO C_Streams a-ssicst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{30e}@anchor{gnat_rm/the_gnat_library id17}@anchor{30f} +@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id17}@anchor{312} @section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads}) @@ -23800,7 +23829,7 @@ strings, avoiding the necessity for an intermediate operation with ordinary strings. @node Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Strings Unbounded Text_IO a-suteio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{310}@anchor{gnat_rm/the_gnat_library id18}@anchor{311} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id18}@anchor{314} @section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads}) @@ -23817,7 +23846,7 @@ wide strings, avoiding the necessity for an intermediate operation with ordinary wide strings. @node Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Task_Initialization a-tasini ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{312}@anchor{gnat_rm/the_gnat_library id19}@anchor{313} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id19}@anchor{316} @section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads}) @@ -23834,7 +23863,7 @@ wide wide strings, avoiding the necessity for an intermediate operation with ordinary wide wide strings. @node Ada Task_Initialization a-tasini ads,Ada Text_IO C_Streams a-tiocst ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{314}@anchor{gnat_rm/the_gnat_library id20}@anchor{315} +@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{317}@anchor{gnat_rm/the_gnat_library id20}@anchor{318} @section @code{Ada.Task_Initialization} (@code{a-tasini.ads}) @@ -23846,7 +23875,7 @@ parameterless procedures. Note that such a handler is only invoked for those tasks activated after the handler is set. @node Ada Text_IO C_Streams a-tiocst ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Task_Initialization a-tasini ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{316}@anchor{gnat_rm/the_gnat_library id21}@anchor{317} +@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id21}@anchor{31a} @section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads}) @@ -23861,7 +23890,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Wide_Characters Unicode a-wichun ads,Ada Text_IO C_Streams a-tiocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{318}@anchor{gnat_rm/the_gnat_library id22}@anchor{319} +@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id22}@anchor{31c} @section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads}) @@ -23876,7 +23905,7 @@ execution (for example a standard input file may be redefined to be interactive). @node Ada Wide_Characters Unicode a-wichun ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{31a}@anchor{gnat_rm/the_gnat_library id23}@anchor{31b} +@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id23}@anchor{31e} @section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads}) @@ -23889,7 +23918,7 @@ This package provides subprograms that allow categorization of Wide_Character values according to Unicode categories. @node Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Characters Unicode a-wichun ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{31c}@anchor{gnat_rm/the_gnat_library id24}@anchor{31d} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id24}@anchor{320} @section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads}) @@ -23904,7 +23933,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{31e}@anchor{gnat_rm/the_gnat_library id25}@anchor{31f} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id25}@anchor{322} @section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads}) @@ -23919,7 +23948,7 @@ execution (for example a standard input file may be redefined to be interactive). @node Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{320}@anchor{gnat_rm/the_gnat_library id26}@anchor{321} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id26}@anchor{324} @section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads}) @@ -23932,7 +23961,7 @@ This package provides subprograms that allow categorization of Wide_Wide_Character values according to Unicode categories. @node Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{322}@anchor{gnat_rm/the_gnat_library id27}@anchor{323} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id27}@anchor{326} @section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads}) @@ -23947,7 +23976,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,GNAT Altivec g-altive ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{324}@anchor{gnat_rm/the_gnat_library id28}@anchor{325} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id28}@anchor{328} @section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads}) @@ -23962,7 +23991,7 @@ change during execution (for example a standard input file may be redefined to be interactive). @node GNAT Altivec g-altive ads,GNAT Altivec Conversions g-altcon ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{326}@anchor{gnat_rm/the_gnat_library id29}@anchor{327} +@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id29}@anchor{32a} @section @code{GNAT.Altivec} (@code{g-altive.ads}) @@ -23975,7 +24004,7 @@ definitions of constants and types common to all the versions of the binding. @node GNAT Altivec Conversions g-altcon ads,GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec g-altive ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{328}@anchor{gnat_rm/the_gnat_library id30}@anchor{329} +@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{32b}@anchor{gnat_rm/the_gnat_library id30}@anchor{32c} @section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads}) @@ -23986,7 +24015,7 @@ binding. This package provides the Vector/View conversion routines. @node GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Conversions g-altcon ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{32a}@anchor{gnat_rm/the_gnat_library id31}@anchor{32b} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id31}@anchor{32e} @section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads}) @@ -24000,7 +24029,7 @@ library. The hard binding is provided as a separate package. This unit is common to both bindings. @node GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Vector_Views g-alvevi ads,GNAT Altivec Vector_Operations g-alveop ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{32c}@anchor{gnat_rm/the_gnat_library id32}@anchor{32d} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id32}@anchor{330} @section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads}) @@ -24012,7 +24041,7 @@ This package exposes the various vector types part of the Ada binding to AltiVec facilities. @node GNAT Altivec Vector_Views g-alvevi ads,GNAT Array_Split g-arrspl ads,GNAT Altivec Vector_Types g-alvety ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{32e}@anchor{gnat_rm/the_gnat_library id33}@anchor{32f} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id33}@anchor{332} @section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads}) @@ -24027,7 +24056,7 @@ vector elements and provides a simple way to initialize vector objects. @node GNAT Array_Split g-arrspl ads,GNAT AWK g-awk ads,GNAT Altivec Vector_Views g-alvevi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{330}@anchor{gnat_rm/the_gnat_library id34}@anchor{331} +@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id34}@anchor{334} @section @code{GNAT.Array_Split} (@code{g-arrspl.ads}) @@ -24040,7 +24069,7 @@ an array wherever the separators appear, and provide direct access to the resulting slices. @node GNAT AWK g-awk ads,GNAT Binary_Search g-binsea ads,GNAT Array_Split g-arrspl ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{332}@anchor{gnat_rm/the_gnat_library id35}@anchor{333} +@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id35}@anchor{336} @section @code{GNAT.AWK} (@code{g-awk.ads}) @@ -24055,7 +24084,7 @@ or more files containing formatted data. The file is viewed as a database where each record is a line and a field is a data element in this line. @node GNAT Binary_Search g-binsea ads,GNAT Bind_Environment g-binenv ads,GNAT AWK g-awk ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-binary-search-g-binsea-ads}@anchor{334}@anchor{gnat_rm/the_gnat_library id36}@anchor{335} +@anchor{gnat_rm/the_gnat_library gnat-binary-search-g-binsea-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id36}@anchor{338} @section @code{GNAT.Binary_Search} (@code{g-binsea.ads}) @@ -24067,7 +24096,7 @@ Allow binary search of a sorted array (or of an array-like container; the generic does not reference the array directly). @node GNAT Bind_Environment g-binenv ads,GNAT Branch_Prediction g-brapre ads,GNAT Binary_Search g-binsea ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{336}@anchor{gnat_rm/the_gnat_library id37}@anchor{337} +@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id37}@anchor{33a} @section @code{GNAT.Bind_Environment} (@code{g-binenv.ads}) @@ -24080,7 +24109,7 @@ These associations can be specified using the @code{-V} binder command line switch. @node GNAT Branch_Prediction g-brapre ads,GNAT Bounded_Buffers g-boubuf ads,GNAT Bind_Environment g-binenv ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{338}@anchor{gnat_rm/the_gnat_library id38}@anchor{339} +@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id38}@anchor{33c} @section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads}) @@ -24091,7 +24120,7 @@ line switch. Provides routines giving hints to the branch predictor of the code generator. @node GNAT Bounded_Buffers g-boubuf ads,GNAT Bounded_Mailboxes g-boumai ads,GNAT Branch_Prediction g-brapre ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{33a}@anchor{gnat_rm/the_gnat_library id39}@anchor{33b} +@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id39}@anchor{33e} @section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads}) @@ -24106,7 +24135,7 @@ useful directly or as parts of the implementations of other abstractions, such as mailboxes. @node GNAT Bounded_Mailboxes g-boumai ads,GNAT Bubble_Sort g-bubsor ads,GNAT Bounded_Buffers g-boubuf ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{33c}@anchor{gnat_rm/the_gnat_library id40}@anchor{33d} +@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id40}@anchor{340} @section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads}) @@ -24119,7 +24148,7 @@ such as mailboxes. Provides a thread-safe asynchronous intertask mailbox communication facility. @node GNAT Bubble_Sort g-bubsor ads,GNAT Bubble_Sort_A g-busora ads,GNAT Bounded_Mailboxes g-boumai ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{33e}@anchor{gnat_rm/the_gnat_library id41}@anchor{33f} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{341}@anchor{gnat_rm/the_gnat_library id41}@anchor{342} @section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads}) @@ -24134,7 +24163,7 @@ data items. Exchange and comparison procedures are provided by passing access-to-procedure values. @node GNAT Bubble_Sort_A g-busora ads,GNAT Bubble_Sort_G g-busorg ads,GNAT Bubble_Sort g-bubsor ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{340}@anchor{gnat_rm/the_gnat_library id42}@anchor{341} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id42}@anchor{344} @section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads}) @@ -24150,7 +24179,7 @@ access-to-procedure values. This is an older version, retained for compatibility. Usually @code{GNAT.Bubble_Sort} will be preferable. @node GNAT Bubble_Sort_G g-busorg ads,GNAT Byte_Order_Mark g-byorma ads,GNAT Bubble_Sort_A g-busora ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{342}@anchor{gnat_rm/the_gnat_library id43}@anchor{343} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id43}@anchor{346} @section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads}) @@ -24166,7 +24195,7 @@ if the procedures can be inlined, at the expense of duplicating code for multiple instantiations. @node GNAT Byte_Order_Mark g-byorma ads,GNAT Byte_Swapping g-bytswa ads,GNAT Bubble_Sort_G g-busorg ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{344}@anchor{gnat_rm/the_gnat_library id44}@anchor{345} +@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id44}@anchor{348} @section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads}) @@ -24182,7 +24211,7 @@ the encoding of the string. The routine includes detection of special XML sequences for various UCS input formats. @node GNAT Byte_Swapping g-bytswa ads,GNAT Calendar g-calend ads,GNAT Byte_Order_Mark g-byorma ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{346}@anchor{gnat_rm/the_gnat_library id45}@anchor{347} +@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id45}@anchor{34a} @section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads}) @@ -24196,7 +24225,7 @@ General routines for swapping the bytes in 2-, 4-, and 8-byte quantities. Machine-specific implementations are available in some cases. @node GNAT Calendar g-calend ads,GNAT Calendar Time_IO g-catiio ads,GNAT Byte_Swapping g-bytswa ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{348}@anchor{gnat_rm/the_gnat_library id46}@anchor{349} +@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id46}@anchor{34c} @section @code{GNAT.Calendar} (@code{g-calend.ads}) @@ -24210,7 +24239,7 @@ Also provides conversion of @code{Ada.Calendar.Time} values to and from the C @code{timeval} format. @node GNAT Calendar Time_IO g-catiio ads,GNAT CRC32 g-crc32 ads,GNAT Calendar g-calend ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{34a}@anchor{gnat_rm/the_gnat_library id47}@anchor{34b} +@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id47}@anchor{34e} @section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads}) @@ -24221,7 +24250,7 @@ C @code{timeval} format. @geindex GNAT.Calendar.Time_IO (g-catiio.ads) @node GNAT CRC32 g-crc32 ads,GNAT Case_Util g-casuti ads,GNAT Calendar Time_IO g-catiio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{34c}@anchor{gnat_rm/the_gnat_library id48}@anchor{34d} +@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{34f}@anchor{gnat_rm/the_gnat_library id48}@anchor{350} @section @code{GNAT.CRC32} (@code{g-crc32.ads}) @@ -24238,7 +24267,7 @@ of this algorithm see Aug. 1988. Sarwate, D.V. @node GNAT Case_Util g-casuti ads,GNAT CGI g-cgi ads,GNAT CRC32 g-crc32 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{34e}@anchor{gnat_rm/the_gnat_library id49}@anchor{34f} +@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id49}@anchor{352} @section @code{GNAT.Case_Util} (@code{g-casuti.ads}) @@ -24253,7 +24282,7 @@ without the overhead of the full casing tables in @code{Ada.Characters.Handling}. @node GNAT CGI g-cgi ads,GNAT CGI Cookie g-cgicoo ads,GNAT Case_Util g-casuti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{350}@anchor{gnat_rm/the_gnat_library id50}@anchor{351} +@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id50}@anchor{354} @section @code{GNAT.CGI} (@code{g-cgi.ads}) @@ -24268,7 +24297,7 @@ builds a table whose index is the key and provides some services to deal with this table. @node GNAT CGI Cookie g-cgicoo ads,GNAT CGI Debug g-cgideb ads,GNAT CGI g-cgi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{352}@anchor{gnat_rm/the_gnat_library id51}@anchor{353} +@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id51}@anchor{356} @section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads}) @@ -24283,7 +24312,7 @@ Common Gateway Interface (CGI). It exports services to deal with Web cookies (piece of information kept in the Web client software). @node GNAT CGI Debug g-cgideb ads,GNAT Command_Line g-comlin ads,GNAT CGI Cookie g-cgicoo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{354}@anchor{gnat_rm/the_gnat_library id52}@anchor{355} +@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id52}@anchor{358} @section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads}) @@ -24295,7 +24324,7 @@ This is a package to help debugging CGI (Common Gateway Interface) programs written in Ada. @node GNAT Command_Line g-comlin ads,GNAT Compiler_Version g-comver ads,GNAT CGI Debug g-cgideb ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{356}@anchor{gnat_rm/the_gnat_library id53}@anchor{357} +@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id53}@anchor{35a} @section @code{GNAT.Command_Line} (@code{g-comlin.ads}) @@ -24308,7 +24337,7 @@ including the ability to scan for named switches with optional parameters and expand file names using wildcard notations. @node GNAT Compiler_Version g-comver ads,GNAT Ctrl_C g-ctrl_c ads,GNAT Command_Line g-comlin ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{358}@anchor{gnat_rm/the_gnat_library id54}@anchor{359} +@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id54}@anchor{35c} @section @code{GNAT.Compiler_Version} (@code{g-comver.ads}) @@ -24326,7 +24355,7 @@ of the compiler if a consistent tool set is used to compile all units of a partition). @node GNAT Ctrl_C g-ctrl_c ads,GNAT Current_Exception g-curexc ads,GNAT Compiler_Version g-comver ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{35a}@anchor{gnat_rm/the_gnat_library id55}@anchor{35b} +@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{35d}@anchor{gnat_rm/the_gnat_library id55}@anchor{35e} @section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads}) @@ -24337,7 +24366,7 @@ of a partition). Provides a simple interface to handle Ctrl-C keyboard events. @node GNAT Current_Exception g-curexc ads,GNAT Debug_Pools g-debpoo ads,GNAT Ctrl_C g-ctrl_c ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{35c}@anchor{gnat_rm/the_gnat_library id56}@anchor{35d} +@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id56}@anchor{360} @section @code{GNAT.Current_Exception} (@code{g-curexc.ads}) @@ -24354,7 +24383,7 @@ This is particularly useful in simulating typical facilities for obtaining information about exceptions provided by Ada 83 compilers. @node GNAT Debug_Pools g-debpoo ads,GNAT Debug_Utilities g-debuti ads,GNAT Current_Exception g-curexc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{35e}@anchor{gnat_rm/the_gnat_library id57}@anchor{35f} +@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id57}@anchor{362} @section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads}) @@ -24371,7 +24400,7 @@ problems. See @code{The GNAT Debug_Pool Facility} section in the @cite{GNAT User’s Guide}. @node GNAT Debug_Utilities g-debuti ads,GNAT Decode_String g-decstr ads,GNAT Debug_Pools g-debpoo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{360}@anchor{gnat_rm/the_gnat_library id58}@anchor{361} +@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id58}@anchor{364} @section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads}) @@ -24384,7 +24413,7 @@ to and from string images of address values. Supports both C and Ada formats for hexadecimal literals. @node GNAT Decode_String g-decstr ads,GNAT Decode_UTF8_String g-deutst ads,GNAT Debug_Utilities g-debuti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{362}@anchor{gnat_rm/the_gnat_library id59}@anchor{363} +@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id59}@anchor{366} @section @code{GNAT.Decode_String} (@code{g-decstr.ads}) @@ -24408,7 +24437,7 @@ Useful in conjunction with Unicode character coding. Note there is a preinstantiation for UTF-8. See next entry. @node GNAT Decode_UTF8_String g-deutst ads,GNAT Directory_Operations g-dirope ads,GNAT Decode_String g-decstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{364}@anchor{gnat_rm/the_gnat_library id60}@anchor{365} +@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id60}@anchor{368} @section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads}) @@ -24429,7 +24458,7 @@ preinstantiation for UTF-8. See next entry. A preinstantiation of GNAT.Decode_Strings for UTF-8 encoding. @node GNAT Directory_Operations g-dirope ads,GNAT Directory_Operations Iteration g-diopit ads,GNAT Decode_UTF8_String g-deutst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{366}@anchor{gnat_rm/the_gnat_library id61}@anchor{367} +@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id61}@anchor{36a} @section @code{GNAT.Directory_Operations} (@code{g-dirope.ads}) @@ -24442,7 +24471,7 @@ the current directory, making new directories, and scanning the files in a directory. @node GNAT Directory_Operations Iteration g-diopit ads,GNAT Dynamic_HTables g-dynhta ads,GNAT Directory_Operations g-dirope ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{368}@anchor{gnat_rm/the_gnat_library id62}@anchor{369} +@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id62}@anchor{36c} @section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads}) @@ -24454,7 +24483,7 @@ A child unit of GNAT.Directory_Operations providing additional operations for iterating through directories. @node GNAT Dynamic_HTables g-dynhta ads,GNAT Dynamic_Tables g-dyntab ads,GNAT Directory_Operations Iteration g-diopit ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{36a}@anchor{gnat_rm/the_gnat_library id63}@anchor{36b} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id63}@anchor{36e} @section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads}) @@ -24472,7 +24501,7 @@ dynamic instances of the hash table, while an instantiation of @code{GNAT.HTable} creates a single instance of the hash table. @node GNAT Dynamic_Tables g-dyntab ads,GNAT Encode_String g-encstr ads,GNAT Dynamic_HTables g-dynhta ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{36c}@anchor{gnat_rm/the_gnat_library id64}@anchor{36d} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id64}@anchor{370} @section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads}) @@ -24492,7 +24521,7 @@ dynamic instances of the table, while an instantiation of @code{GNAT.Table} creates a single instance of the table type. @node GNAT Encode_String g-encstr ads,GNAT Encode_UTF8_String g-enutst ads,GNAT Dynamic_Tables g-dyntab ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{36e}@anchor{gnat_rm/the_gnat_library id65}@anchor{36f} +@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id65}@anchor{372} @section @code{GNAT.Encode_String} (@code{g-encstr.ads}) @@ -24514,7 +24543,7 @@ encoding method. Useful in conjunction with Unicode character coding. Note there is a preinstantiation for UTF-8. See next entry. @node GNAT Encode_UTF8_String g-enutst ads,GNAT Exception_Actions g-excact ads,GNAT Encode_String g-encstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{370}@anchor{gnat_rm/the_gnat_library id66}@anchor{371} +@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id66}@anchor{374} @section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads}) @@ -24535,7 +24564,7 @@ Note there is a preinstantiation for UTF-8. See next entry. A preinstantiation of GNAT.Encode_Strings for UTF-8 encoding. @node GNAT Exception_Actions g-excact ads,GNAT Exception_Traces g-exctra ads,GNAT Encode_UTF8_String g-enutst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{372}@anchor{gnat_rm/the_gnat_library id67}@anchor{373} +@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id67}@anchor{376} @section @code{GNAT.Exception_Actions} (@code{g-excact.ads}) @@ -24548,7 +24577,7 @@ for specific exceptions, or when any exception is raised. This can be used for instance to force a core dump to ease debugging. @node GNAT Exception_Traces g-exctra ads,GNAT Exceptions g-except ads,GNAT Exception_Actions g-excact ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{374}@anchor{gnat_rm/the_gnat_library id68}@anchor{375} +@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id68}@anchor{378} @section @code{GNAT.Exception_Traces} (@code{g-exctra.ads}) @@ -24562,7 +24591,7 @@ Provides an interface allowing to control automatic output upon exception occurrences. @node GNAT Exceptions g-except ads,GNAT Expect g-expect ads,GNAT Exception_Traces g-exctra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{376}@anchor{gnat_rm/the_gnat_library id69}@anchor{377} +@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id69}@anchor{37a} @section @code{GNAT.Exceptions} (@code{g-except.ads}) @@ -24583,7 +24612,7 @@ predefined exceptions, and for example allows raising @code{Constraint_Error} with a message from a pure subprogram. @node GNAT Expect g-expect ads,GNAT Expect TTY g-exptty ads,GNAT Exceptions g-except ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{378}@anchor{gnat_rm/the_gnat_library id70}@anchor{379} +@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{37b}@anchor{gnat_rm/the_gnat_library id70}@anchor{37c} @section @code{GNAT.Expect} (@code{g-expect.ads}) @@ -24599,7 +24628,7 @@ It is not implemented for cross ports, and in particular is not implemented for VxWorks or LynxOS. @node GNAT Expect TTY g-exptty ads,GNAT Float_Control g-flocon ads,GNAT Expect g-expect ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{37a}@anchor{gnat_rm/the_gnat_library id71}@anchor{37b} +@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id71}@anchor{37e} @section @code{GNAT.Expect.TTY} (@code{g-exptty.ads}) @@ -24611,7 +24640,7 @@ ports. It is not implemented for cross ports, and in particular is not implemented for VxWorks or LynxOS. @node GNAT Float_Control g-flocon ads,GNAT Formatted_String g-forstr ads,GNAT Expect TTY g-exptty ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{37c}@anchor{gnat_rm/the_gnat_library id72}@anchor{37d} +@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id72}@anchor{380} @section @code{GNAT.Float_Control} (@code{g-flocon.ads}) @@ -24625,7 +24654,7 @@ library calls may cause this mode to be modified, and the Reset procedure in this package can be used to reestablish the required mode. @node GNAT Formatted_String g-forstr ads,GNAT Generic_Fast_Math_Functions g-gfmafu ads,GNAT Float_Control g-flocon ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{37e}@anchor{gnat_rm/the_gnat_library id73}@anchor{37f} +@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id73}@anchor{382} @section @code{GNAT.Formatted_String} (@code{g-forstr.ads}) @@ -24640,7 +24669,7 @@ derived from Integer, Float or enumerations as values for the formatted string. @node GNAT Generic_Fast_Math_Functions g-gfmafu ads,GNAT Heap_Sort g-heasor ads,GNAT Formatted_String g-forstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-generic-fast-math-functions-g-gfmafu-ads}@anchor{380}@anchor{gnat_rm/the_gnat_library id74}@anchor{381} +@anchor{gnat_rm/the_gnat_library gnat-generic-fast-math-functions-g-gfmafu-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id74}@anchor{384} @section @code{GNAT.Generic_Fast_Math_Functions} (@code{g-gfmafu.ads}) @@ -24658,7 +24687,7 @@ have a vector implementation that can be automatically used by the compiler when auto-vectorization is enabled. @node GNAT Heap_Sort g-heasor ads,GNAT Heap_Sort_A g-hesora ads,GNAT Generic_Fast_Math_Functions g-gfmafu ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{382}@anchor{gnat_rm/the_gnat_library id75}@anchor{383} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id75}@anchor{386} @section @code{GNAT.Heap_Sort} (@code{g-heasor.ads}) @@ -24672,7 +24701,7 @@ access-to-procedure values. The algorithm used is a modified heap sort that performs approximately N*log(N) comparisons in the worst case. @node GNAT Heap_Sort_A g-hesora ads,GNAT Heap_Sort_G g-hesorg ads,GNAT Heap_Sort g-heasor ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{384}@anchor{gnat_rm/the_gnat_library id76}@anchor{385} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{387}@anchor{gnat_rm/the_gnat_library id76}@anchor{388} @section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads}) @@ -24688,7 +24717,7 @@ This differs from @code{GNAT.Heap_Sort} in having a less convenient interface, but may be slightly more efficient. @node GNAT Heap_Sort_G g-hesorg ads,GNAT HTable g-htable ads,GNAT Heap_Sort_A g-hesora ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{386}@anchor{gnat_rm/the_gnat_library id77}@anchor{387} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id77}@anchor{38a} @section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads}) @@ -24702,7 +24731,7 @@ if the procedures can be inlined, at the expense of duplicating code for multiple instantiations. @node GNAT HTable g-htable ads,GNAT IO g-io ads,GNAT Heap_Sort_G g-hesorg ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{388}@anchor{gnat_rm/the_gnat_library id78}@anchor{389} +@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id78}@anchor{38c} @section @code{GNAT.HTable} (@code{g-htable.ads}) @@ -24715,7 +24744,7 @@ data. Provides two approaches, one a simple static approach, and the other allowing arbitrary dynamic hash tables. @node GNAT IO g-io ads,GNAT IO_Aux g-io_aux ads,GNAT HTable g-htable ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{38a}@anchor{gnat_rm/the_gnat_library id79}@anchor{38b} +@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{38d}@anchor{gnat_rm/the_gnat_library id79}@anchor{38e} @section @code{GNAT.IO} (@code{g-io.ads}) @@ -24731,7 +24760,7 @@ Standard_Input, and writing characters, strings and integers to either Standard_Output or Standard_Error. @node GNAT IO_Aux g-io_aux ads,GNAT Lock_Files g-locfil ads,GNAT IO g-io ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{38c}@anchor{gnat_rm/the_gnat_library id80}@anchor{38d} +@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{38f}@anchor{gnat_rm/the_gnat_library id80}@anchor{390} @section @code{GNAT.IO_Aux} (@code{g-io_aux.ads}) @@ -24745,7 +24774,7 @@ Provides some auxiliary functions for use with Text_IO, including a test for whether a file exists, and functions for reading a line of text. @node GNAT Lock_Files g-locfil ads,GNAT MBBS_Discrete_Random g-mbdira ads,GNAT IO_Aux g-io_aux ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id81}@anchor{38f} +@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{391}@anchor{gnat_rm/the_gnat_library id81}@anchor{392} @section @code{GNAT.Lock_Files} (@code{g-locfil.ads}) @@ -24759,7 +24788,7 @@ Provides a general interface for using files as locks. Can be used for providing program level synchronization. @node GNAT MBBS_Discrete_Random g-mbdira ads,GNAT MBBS_Float_Random g-mbflra ads,GNAT Lock_Files g-locfil ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id82}@anchor{391} +@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{393}@anchor{gnat_rm/the_gnat_library id82}@anchor{394} @section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads}) @@ -24771,7 +24800,7 @@ The original implementation of @code{Ada.Numerics.Discrete_Random}. Uses a modified version of the Blum-Blum-Shub generator. @node GNAT MBBS_Float_Random g-mbflra ads,GNAT MD5 g-md5 ads,GNAT MBBS_Discrete_Random g-mbdira ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{392}@anchor{gnat_rm/the_gnat_library id83}@anchor{393} +@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{395}@anchor{gnat_rm/the_gnat_library id83}@anchor{396} @section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads}) @@ -24783,7 +24812,7 @@ The original implementation of @code{Ada.Numerics.Float_Random}. Uses a modified version of the Blum-Blum-Shub generator. @node GNAT MD5 g-md5 ads,GNAT Memory_Dump g-memdum ads,GNAT MBBS_Float_Random g-mbflra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{394}@anchor{gnat_rm/the_gnat_library id84}@anchor{395} +@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{397}@anchor{gnat_rm/the_gnat_library id84}@anchor{398} @section @code{GNAT.MD5} (@code{g-md5.ads}) @@ -24796,7 +24825,7 @@ the HMAC-MD5 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT Memory_Dump g-memdum ads,GNAT Most_Recent_Exception g-moreex ads,GNAT MD5 g-md5 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id85}@anchor{397} +@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{399}@anchor{gnat_rm/the_gnat_library id85}@anchor{39a} @section @code{GNAT.Memory_Dump} (@code{g-memdum.ads}) @@ -24809,7 +24838,7 @@ standard output or standard error files. Uses GNAT.IO for actual output. @node GNAT Most_Recent_Exception g-moreex ads,GNAT OS_Lib g-os_lib ads,GNAT Memory_Dump g-memdum ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{398}@anchor{gnat_rm/the_gnat_library id86}@anchor{399} +@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{39b}@anchor{gnat_rm/the_gnat_library id86}@anchor{39c} @section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads}) @@ -24823,7 +24852,7 @@ various logging purposes, including duplicating functionality of some Ada 83 implementation dependent extensions. @node GNAT OS_Lib g-os_lib ads,GNAT Perfect_Hash_Generators g-pehage ads,GNAT Most_Recent_Exception g-moreex ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id87}@anchor{39b} +@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{39d}@anchor{gnat_rm/the_gnat_library id87}@anchor{39e} @section @code{GNAT.OS_Lib} (@code{g-os_lib.ads}) @@ -24839,7 +24868,7 @@ including a portable spawn procedure, and access to environment variables and error return codes. @node GNAT Perfect_Hash_Generators g-pehage ads,GNAT Random_Numbers g-rannum ads,GNAT OS_Lib g-os_lib ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id88}@anchor{39d} +@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{39f}@anchor{gnat_rm/the_gnat_library id88}@anchor{3a0} @section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads}) @@ -24857,7 +24886,7 @@ hashcode are in the same order. These hashing functions are very convenient for use with realtime applications. @node GNAT Random_Numbers g-rannum ads,GNAT Regexp g-regexp ads,GNAT Perfect_Hash_Generators g-pehage ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id89}@anchor{39f} +@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{3a1}@anchor{gnat_rm/the_gnat_library id89}@anchor{3a2} @section @code{GNAT.Random_Numbers} (@code{g-rannum.ads}) @@ -24871,7 +24900,7 @@ however NOT suitable for situations requiring cryptographically secure randomness. @node GNAT Regexp g-regexp ads,GNAT Registry g-regist ads,GNAT Random_Numbers g-rannum ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{275}@anchor{gnat_rm/the_gnat_library id90}@anchor{3a0} +@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{278}@anchor{gnat_rm/the_gnat_library id90}@anchor{3a3} @section @code{GNAT.Regexp} (@code{g-regexp.ads}) @@ -24887,7 +24916,7 @@ simplest of the three pattern matching packages provided, and is particularly suitable for ‘file globbing’ applications. @node GNAT Registry g-regist ads,GNAT Regpat g-regpat ads,GNAT Regexp g-regexp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{3a1}@anchor{gnat_rm/the_gnat_library id91}@anchor{3a2} +@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id91}@anchor{3a5} @section @code{GNAT.Registry} (@code{g-regist.ads}) @@ -24901,7 +24930,7 @@ registry API, but at a lower level of abstraction, refer to the Win32.Winreg package provided with the Win32Ada binding @node GNAT Regpat g-regpat ads,GNAT Rewrite_Data g-rewdat ads,GNAT Registry g-regist ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{3a3}@anchor{gnat_rm/the_gnat_library id92}@anchor{3a4} +@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{3a6}@anchor{gnat_rm/the_gnat_library id92}@anchor{3a7} @section @code{GNAT.Regpat} (@code{g-regpat.ads}) @@ -24916,7 +24945,7 @@ from the original V7 style regular expression library written in C by Henry Spencer (and binary compatible with this C library). @node GNAT Rewrite_Data g-rewdat ads,GNAT Secondary_Stack_Info g-sestin ads,GNAT Regpat g-regpat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{3a5}@anchor{gnat_rm/the_gnat_library id93}@anchor{3a6} +@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id93}@anchor{3a9} @section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads}) @@ -24930,7 +24959,7 @@ full content to be processed is not loaded into memory all at once. This makes this interface usable for large files or socket streams. @node GNAT Secondary_Stack_Info g-sestin ads,GNAT Semaphores g-semaph ads,GNAT Rewrite_Data g-rewdat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{3a7}@anchor{gnat_rm/the_gnat_library id94}@anchor{3a8} +@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id94}@anchor{3ab} @section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads}) @@ -24942,7 +24971,7 @@ Provides the capability to query the high water mark of the current task’s secondary stack. @node GNAT Semaphores g-semaph ads,GNAT Serial_Communications g-sercom ads,GNAT Secondary_Stack_Info g-sestin ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{3a9}@anchor{gnat_rm/the_gnat_library id95}@anchor{3aa} +@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id95}@anchor{3ad} @section @code{GNAT.Semaphores} (@code{g-semaph.ads}) @@ -24953,7 +24982,7 @@ secondary stack. Provides classic counting and binary semaphores using protected types. @node GNAT Serial_Communications g-sercom ads,GNAT SHA1 g-sha1 ads,GNAT Semaphores g-semaph ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{3ab}@anchor{gnat_rm/the_gnat_library id96}@anchor{3ac} +@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id96}@anchor{3af} @section @code{GNAT.Serial_Communications} (@code{g-sercom.ads}) @@ -24965,7 +24994,7 @@ Provides a simple interface to send and receive data over a serial port. This is only supported on GNU/Linux and Windows. @node GNAT SHA1 g-sha1 ads,GNAT SHA224 g-sha224 ads,GNAT Serial_Communications g-sercom ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{3ad}@anchor{gnat_rm/the_gnat_library id97}@anchor{3ae} +@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id97}@anchor{3b1} @section @code{GNAT.SHA1} (@code{g-sha1.ads}) @@ -24978,7 +25007,7 @@ and RFC 3174, and the HMAC-SHA1 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA224 g-sha224 ads,GNAT SHA256 g-sha256 ads,GNAT SHA1 g-sha1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3af}@anchor{gnat_rm/the_gnat_library id98}@anchor{3b0} +@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id98}@anchor{3b3} @section @code{GNAT.SHA224} (@code{g-sha224.ads}) @@ -24991,7 +25020,7 @@ and the HMAC-SHA224 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA256 g-sha256 ads,GNAT SHA384 g-sha384 ads,GNAT SHA224 g-sha224 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3b1}@anchor{gnat_rm/the_gnat_library id99}@anchor{3b2} +@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id99}@anchor{3b5} @section @code{GNAT.SHA256} (@code{g-sha256.ads}) @@ -25004,7 +25033,7 @@ and the HMAC-SHA256 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA384 g-sha384 ads,GNAT SHA512 g-sha512 ads,GNAT SHA256 g-sha256 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3b3}@anchor{gnat_rm/the_gnat_library id100}@anchor{3b4} +@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3b6}@anchor{gnat_rm/the_gnat_library id100}@anchor{3b7} @section @code{GNAT.SHA384} (@code{g-sha384.ads}) @@ -25017,7 +25046,7 @@ and the HMAC-SHA384 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA512 g-sha512 ads,GNAT Signals g-signal ads,GNAT SHA384 g-sha384 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3b5}@anchor{gnat_rm/the_gnat_library id101}@anchor{3b6} +@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id101}@anchor{3b9} @section @code{GNAT.SHA512} (@code{g-sha512.ads}) @@ -25030,7 +25059,7 @@ and the HMAC-SHA512 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT Signals g-signal ads,GNAT Sockets g-socket ads,GNAT SHA512 g-sha512 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3b7}@anchor{gnat_rm/the_gnat_library id102}@anchor{3b8} +@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id102}@anchor{3bb} @section @code{GNAT.Signals} (@code{g-signal.ads}) @@ -25042,7 +25071,7 @@ Provides the ability to manipulate the blocked status of signals on supported targets. @node GNAT Sockets g-socket ads,GNAT Source_Info g-souinf ads,GNAT Signals g-signal ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3b9}@anchor{gnat_rm/the_gnat_library id103}@anchor{3ba} +@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3bc}@anchor{gnat_rm/the_gnat_library id103}@anchor{3bd} @section @code{GNAT.Sockets} (@code{g-socket.ads}) @@ -25057,7 +25086,7 @@ on all native GNAT ports and on VxWorks cross ports. It is not implemented for the LynxOS cross port. @node GNAT Source_Info g-souinf ads,GNAT Spelling_Checker g-speche ads,GNAT Sockets g-socket ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3bb}@anchor{gnat_rm/the_gnat_library id104}@anchor{3bc} +@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id104}@anchor{3bf} @section @code{GNAT.Source_Info} (@code{g-souinf.ads}) @@ -25071,7 +25100,7 @@ subprograms yielding the date and time of the current compilation (like the C macros @code{__DATE__} and @code{__TIME__}) @node GNAT Spelling_Checker g-speche ads,GNAT Spelling_Checker_Generic g-spchge ads,GNAT Source_Info g-souinf ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3bd}@anchor{gnat_rm/the_gnat_library id105}@anchor{3be} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id105}@anchor{3c1} @section @code{GNAT.Spelling_Checker} (@code{g-speche.ads}) @@ -25083,7 +25112,7 @@ Provides a function for determining whether one string is a plausible near misspelling of another string. @node GNAT Spelling_Checker_Generic g-spchge ads,GNAT Spitbol Patterns g-spipat ads,GNAT Spelling_Checker g-speche ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3bf}@anchor{gnat_rm/the_gnat_library id106}@anchor{3c0} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id106}@anchor{3c3} @section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads}) @@ -25096,7 +25125,7 @@ determining whether one string is a plausible near misspelling of another string. @node GNAT Spitbol Patterns g-spipat ads,GNAT Spitbol g-spitbo ads,GNAT Spelling_Checker_Generic g-spchge ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3c1}@anchor{gnat_rm/the_gnat_library id107}@anchor{3c2} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id107}@anchor{3c5} @section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads}) @@ -25112,7 +25141,7 @@ the SNOBOL4 dynamic pattern construction and matching capabilities, using the efficient algorithm developed by Robert Dewar for the SPITBOL system. @node GNAT Spitbol g-spitbo ads,GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Patterns g-spipat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3c3}@anchor{gnat_rm/the_gnat_library id108}@anchor{3c4} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id108}@anchor{3c7} @section @code{GNAT.Spitbol} (@code{g-spitbo.ads}) @@ -25127,7 +25156,7 @@ useful for constructing arbitrary mappings from strings in the style of the SNOBOL4 TABLE function. @node GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol g-spitbo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3c5}@anchor{gnat_rm/the_gnat_library id109}@anchor{3c6} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3c8}@anchor{gnat_rm/the_gnat_library id109}@anchor{3c9} @section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads}) @@ -25142,7 +25171,7 @@ for type @code{Standard.Boolean}, giving an implementation of sets of string values. @node GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol Table_VString g-sptavs ads,GNAT Spitbol Table_Boolean g-sptabo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3c7}@anchor{gnat_rm/the_gnat_library id110}@anchor{3c8} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id110}@anchor{3cb} @section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads}) @@ -25159,7 +25188,7 @@ for type @code{Standard.Integer}, giving an implementation of maps from string to integer values. @node GNAT Spitbol Table_VString g-sptavs ads,GNAT SSE g-sse ads,GNAT Spitbol Table_Integer g-sptain ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3c9}@anchor{gnat_rm/the_gnat_library id111}@anchor{3ca} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id111}@anchor{3cd} @section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads}) @@ -25176,7 +25205,7 @@ a variable length string type, giving an implementation of general maps from strings to strings. @node GNAT SSE g-sse ads,GNAT SSE Vector_Types g-ssvety ads,GNAT Spitbol Table_VString g-sptavs ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3cb}@anchor{gnat_rm/the_gnat_library id112}@anchor{3cc} +@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id112}@anchor{3cf} @section @code{GNAT.SSE} (@code{g-sse.ads}) @@ -25188,7 +25217,7 @@ targets. It exposes vector component types together with a general introduction to the binding contents and use. @node GNAT SSE Vector_Types g-ssvety ads,GNAT String_Hash g-strhas ads,GNAT SSE g-sse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3cd}@anchor{gnat_rm/the_gnat_library id113}@anchor{3ce} +@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id113}@anchor{3d1} @section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads}) @@ -25197,7 +25226,7 @@ introduction to the binding contents and use. SSE vector types for use with SSE related intrinsics. @node GNAT String_Hash g-strhas ads,GNAT Strings g-string ads,GNAT SSE Vector_Types g-ssvety ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3cf}@anchor{gnat_rm/the_gnat_library id114}@anchor{3d0} +@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3d2}@anchor{gnat_rm/the_gnat_library id114}@anchor{3d3} @section @code{GNAT.String_Hash} (@code{g-strhas.ads}) @@ -25209,7 +25238,7 @@ Provides a generic hash function working on arrays of scalars. Both the scalar type and the hash result type are parameters. @node GNAT Strings g-string ads,GNAT String_Split g-strspl ads,GNAT String_Hash g-strhas ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3d1}@anchor{gnat_rm/the_gnat_library id115}@anchor{3d2} +@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3d4}@anchor{gnat_rm/the_gnat_library id115}@anchor{3d5} @section @code{GNAT.Strings} (@code{g-string.ads}) @@ -25219,7 +25248,7 @@ Common String access types and related subprograms. Basically it defines a string access and an array of string access types. @node GNAT String_Split g-strspl ads,GNAT Table g-table ads,GNAT Strings g-string ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3d3}@anchor{gnat_rm/the_gnat_library id116}@anchor{3d4} +@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id116}@anchor{3d7} @section @code{GNAT.String_Split} (@code{g-strspl.ads}) @@ -25233,7 +25262,7 @@ to the resulting slices. This package is instantiated from @code{GNAT.Array_Split}. @node GNAT Table g-table ads,GNAT Task_Lock g-tasloc ads,GNAT String_Split g-strspl ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3d5}@anchor{gnat_rm/the_gnat_library id117}@anchor{3d6} +@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3d8}@anchor{gnat_rm/the_gnat_library id117}@anchor{3d9} @section @code{GNAT.Table} (@code{g-table.ads}) @@ -25253,7 +25282,7 @@ while an instantiation of @code{GNAT.Dynamic_Tables} creates a type that can be used to define dynamic instances of the table. @node GNAT Task_Lock g-tasloc ads,GNAT Time_Stamp g-timsta ads,GNAT Table g-table ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3d7}@anchor{gnat_rm/the_gnat_library id118}@anchor{3d8} +@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3da}@anchor{gnat_rm/the_gnat_library id118}@anchor{3db} @section @code{GNAT.Task_Lock} (@code{g-tasloc.ads}) @@ -25270,7 +25299,7 @@ single global task lock. Appropriate for use in situations where contention between tasks is very rarely expected. @node GNAT Time_Stamp g-timsta ads,GNAT Threads g-thread ads,GNAT Task_Lock g-tasloc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3d9}@anchor{gnat_rm/the_gnat_library id119}@anchor{3da} +@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id119}@anchor{3dd} @section @code{GNAT.Time_Stamp} (@code{g-timsta.ads}) @@ -25285,7 +25314,7 @@ represents the current date and time in ISO 8601 format. This is a very simple routine with minimal code and there are no dependencies on any other unit. @node GNAT Threads g-thread ads,GNAT Traceback g-traceb ads,GNAT Time_Stamp g-timsta ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3db}@anchor{gnat_rm/the_gnat_library id120}@anchor{3dc} +@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3de}@anchor{gnat_rm/the_gnat_library id120}@anchor{3df} @section @code{GNAT.Threads} (@code{g-thread.ads}) @@ -25302,7 +25331,7 @@ further details if your program has threads that are created by a non-Ada environment which then accesses Ada code. @node GNAT Traceback g-traceb ads,GNAT Traceback Symbolic g-trasym ads,GNAT Threads g-thread ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3dd}@anchor{gnat_rm/the_gnat_library id121}@anchor{3de} +@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3e0}@anchor{gnat_rm/the_gnat_library id121}@anchor{3e1} @section @code{GNAT.Traceback} (@code{g-traceb.ads}) @@ -25314,7 +25343,7 @@ Provides a facility for obtaining non-symbolic traceback information, useful in various debugging situations. @node GNAT Traceback Symbolic g-trasym ads,GNAT UTF_32 g-utf_32 ads,GNAT Traceback g-traceb ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3df}@anchor{gnat_rm/the_gnat_library id122}@anchor{3e0} +@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3e2}@anchor{gnat_rm/the_gnat_library id122}@anchor{3e3} @section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads}) @@ -25323,7 +25352,7 @@ in various debugging situations. @geindex Trace back facilities @node GNAT UTF_32 g-utf_32 ads,GNAT UTF_32_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-utf-32-ads}@anchor{3e1}@anchor{gnat_rm/the_gnat_library id123}@anchor{3e2} +@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-utf-32-ads}@anchor{3e4}@anchor{gnat_rm/the_gnat_library id123}@anchor{3e5} @section @code{GNAT.UTF_32} (@code{g-utf_32.ads}) @@ -25342,7 +25371,7 @@ lower case to upper case fold routine corresponding to the Ada 2005 rules for identifier equivalence. @node GNAT UTF_32_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-utf_32 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-utf-32-spelling-checker-g-u3spch-ads}@anchor{3e3}@anchor{gnat_rm/the_gnat_library id124}@anchor{3e4} +@anchor{gnat_rm/the_gnat_library gnat-utf-32-spelling-checker-g-u3spch-ads}@anchor{3e6}@anchor{gnat_rm/the_gnat_library id124}@anchor{3e7} @section @code{GNAT.UTF_32_Spelling_Checker} (@code{g-u3spch.ads}) @@ -25355,7 +25384,7 @@ near misspelling of another wide wide string, where the strings are represented using the UTF_32_String type defined in System.Wch_Cnv. @node GNAT Wide_Spelling_Checker g-wispch ads,GNAT Wide_String_Split g-wistsp ads,GNAT UTF_32_Spelling_Checker g-u3spch ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3e5}@anchor{gnat_rm/the_gnat_library id125}@anchor{3e6} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3e8}@anchor{gnat_rm/the_gnat_library id125}@anchor{3e9} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads}) @@ -25367,7 +25396,7 @@ Provides a function for determining whether one wide string is a plausible near misspelling of another wide string. @node GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Spelling_Checker g-wispch ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3e7}@anchor{gnat_rm/the_gnat_library id126}@anchor{3e8} +@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3ea}@anchor{gnat_rm/the_gnat_library id126}@anchor{3eb} @section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads}) @@ -25381,7 +25410,7 @@ to the resulting slices. This package is instantiated from @code{GNAT.Array_Split}. @node GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Wide_String_Split g-zistsp ads,GNAT Wide_String_Split g-wistsp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3e9}@anchor{gnat_rm/the_gnat_library id127}@anchor{3ea} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3ec}@anchor{gnat_rm/the_gnat_library id127}@anchor{3ed} @section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads}) @@ -25393,7 +25422,7 @@ Provides a function for determining whether one wide wide string is a plausible near misspelling of another wide wide string. @node GNAT Wide_Wide_String_Split g-zistsp ads,Interfaces C Extensions i-cexten ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3eb}@anchor{gnat_rm/the_gnat_library id128}@anchor{3ec} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3ee}@anchor{gnat_rm/the_gnat_library id128}@anchor{3ef} @section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads}) @@ -25407,7 +25436,7 @@ to the resulting slices. This package is instantiated from @code{GNAT.Array_Split}. @node Interfaces C Extensions i-cexten ads,Interfaces C Streams i-cstrea ads,GNAT Wide_Wide_String_Split g-zistsp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id129}@anchor{3ed}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3ee} +@anchor{gnat_rm/the_gnat_library id129}@anchor{3f0}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3f1} @section @code{Interfaces.C.Extensions} (@code{i-cexten.ads}) @@ -25418,7 +25447,7 @@ for use with either manually or automatically generated bindings to C libraries. @node Interfaces C Streams i-cstrea ads,Interfaces Packed_Decimal i-pacdec ads,Interfaces C Extensions i-cexten ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id130}@anchor{3ef}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3f0} +@anchor{gnat_rm/the_gnat_library id130}@anchor{3f2}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3f3} @section @code{Interfaces.C.Streams} (@code{i-cstrea.ads}) @@ -25431,7 +25460,7 @@ This package is a binding for the most commonly used operations on C streams. @node Interfaces Packed_Decimal i-pacdec ads,Interfaces VxWorks i-vxwork ads,Interfaces C Streams i-cstrea ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id131}@anchor{3f1}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3f2} +@anchor{gnat_rm/the_gnat_library id131}@anchor{3f4}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3f5} @section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads}) @@ -25446,7 +25475,7 @@ from a packed decimal format compatible with that used on IBM mainframes. @node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id132}@anchor{3f3}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3f4} +@anchor{gnat_rm/the_gnat_library id132}@anchor{3f6}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3f7} @section @code{Interfaces.VxWorks} (@code{i-vxwork.ads}) @@ -25460,7 +25489,7 @@ mainframes. This package provides a limited binding to the VxWorks API. @node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks i-vxwork ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id133}@anchor{3f5}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3f6} +@anchor{gnat_rm/the_gnat_library id133}@anchor{3f8}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3f9} @section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads}) @@ -25483,7 +25512,7 @@ function codes. A particular use of this package is to enable the use of Get_Immediate under VxWorks. @node System Address_Image s-addima ads,System Assertions s-assert ads,Interfaces VxWorks IO i-vxwoio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id134}@anchor{3f7}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3f8} +@anchor{gnat_rm/the_gnat_library id134}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3fb} @section @code{System.Address_Image} (@code{s-addima.ads}) @@ -25499,7 +25528,7 @@ function that gives an (implementation dependent) string which identifies an address. @node System Assertions s-assert ads,System Atomic_Counters s-atocou ads,System Address_Image s-addima ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id135}@anchor{3f9}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3fa} +@anchor{gnat_rm/the_gnat_library id135}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3fd} @section @code{System.Assertions} (@code{s-assert.ads}) @@ -25515,7 +25544,7 @@ by an run-time assertion failure, as well as the routine that is used internally to raise this assertion. @node System Atomic_Counters s-atocou ads,System Memory s-memory ads,System Assertions s-assert ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id136}@anchor{3fb}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3fc} +@anchor{gnat_rm/the_gnat_library id136}@anchor{3fe}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3ff} @section @code{System.Atomic_Counters} (@code{s-atocou.ads}) @@ -25529,7 +25558,7 @@ on most targets, including all Alpha, AARCH64, ARM, ia64, PowerPC, SPARC V9, x86, and x86_64 platforms. @node System Memory s-memory ads,System Multiprocessors s-multip ads,System Atomic_Counters s-atocou ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id137}@anchor{3fd}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3fe} +@anchor{gnat_rm/the_gnat_library id137}@anchor{400}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{401} @section @code{System.Memory} (@code{s-memory.ads}) @@ -25547,7 +25576,7 @@ calls to this unit may be made for low level allocation uses (for example see the body of @code{GNAT.Tables}). @node System Multiprocessors s-multip ads,System Multiprocessors Dispatching_Domains s-mudido ads,System Memory s-memory ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id138}@anchor{3ff}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{400} +@anchor{gnat_rm/the_gnat_library id138}@anchor{402}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{403} @section @code{System.Multiprocessors} (@code{s-multip.ads}) @@ -25560,7 +25589,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is technically an implementation-defined addition). @node System Multiprocessors Dispatching_Domains s-mudido ads,System Partition_Interface s-parint ads,System Multiprocessors s-multip ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id139}@anchor{401}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{402} +@anchor{gnat_rm/the_gnat_library id139}@anchor{404}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{405} @section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads}) @@ -25573,7 +25602,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is technically an implementation-defined addition). @node System Partition_Interface s-parint ads,System Pool_Global s-pooglo ads,System Multiprocessors Dispatching_Domains s-mudido ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id140}@anchor{403}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{404} +@anchor{gnat_rm/the_gnat_library id140}@anchor{406}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{407} @section @code{System.Partition_Interface} (@code{s-parint.ads}) @@ -25586,7 +25615,7 @@ is used primarily in a distribution context when using Annex E with @code{GLADE}. @node System Pool_Global s-pooglo ads,System Pool_Local s-pooloc ads,System Partition_Interface s-parint ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id141}@anchor{405}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{406} +@anchor{gnat_rm/the_gnat_library id141}@anchor{408}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{409} @section @code{System.Pool_Global} (@code{s-pooglo.ads}) @@ -25603,7 +25632,7 @@ declared. It uses malloc/free to allocate/free and does not attempt to do any automatic reclamation. @node System Pool_Local s-pooloc ads,System Restrictions s-restri ads,System Pool_Global s-pooglo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id142}@anchor{407}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{408} +@anchor{gnat_rm/the_gnat_library id142}@anchor{40a}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{40b} @section @code{System.Pool_Local} (@code{s-pooloc.ads}) @@ -25620,7 +25649,7 @@ a list of allocated blocks, so that all storage allocated for the pool can be freed automatically when the pool is finalized. @node System Restrictions s-restri ads,System Rident s-rident ads,System Pool_Local s-pooloc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id143}@anchor{409}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{40a} +@anchor{gnat_rm/the_gnat_library id143}@anchor{40c}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{40d} @section @code{System.Restrictions} (@code{s-restri.ads}) @@ -25636,7 +25665,7 @@ compiler determined information on which restrictions are violated by one or more packages in the partition. @node System Rident s-rident ads,System Strings Stream_Ops s-ststop ads,System Restrictions s-restri ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id144}@anchor{40b}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{40c} +@anchor{gnat_rm/the_gnat_library id144}@anchor{40e}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{40f} @section @code{System.Rident} (@code{s-rident.ads}) @@ -25652,7 +25681,7 @@ since the necessary instantiation is included in package System.Restrictions. @node System Strings Stream_Ops s-ststop ads,System Unsigned_Types s-unstyp ads,System Rident s-rident ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id145}@anchor{40d}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{40e} +@anchor{gnat_rm/the_gnat_library id145}@anchor{410}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{411} @section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads}) @@ -25668,7 +25697,7 @@ stream attributes are applied to string types, but the subprograms in this package can be used directly by application programs. @node System Unsigned_Types s-unstyp ads,System Wch_Cnv s-wchcnv ads,System Strings Stream_Ops s-ststop ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id146}@anchor{40f}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{410} +@anchor{gnat_rm/the_gnat_library id146}@anchor{412}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{413} @section @code{System.Unsigned_Types} (@code{s-unstyp.ads}) @@ -25681,7 +25710,7 @@ also contains some related definitions for other specialized types used by the compiler in connection with packed array types. @node System Wch_Cnv s-wchcnv ads,System Wch_Con s-wchcon ads,System Unsigned_Types s-unstyp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id147}@anchor{411}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{412} +@anchor{gnat_rm/the_gnat_library id147}@anchor{414}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{415} @section @code{System.Wch_Cnv} (@code{s-wchcnv.ads}) @@ -25702,7 +25731,7 @@ encoding method. It uses definitions in package @code{System.Wch_Con}. @node System Wch_Con s-wchcon ads,,System Wch_Cnv s-wchcnv ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id148}@anchor{413}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{414} +@anchor{gnat_rm/the_gnat_library id148}@anchor{416}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{417} @section @code{System.Wch_Con} (@code{s-wchcon.ads}) @@ -25714,7 +25743,7 @@ in ordinary strings. These definitions are used by the package @code{System.Wch_Cnv}. @node Interfacing to Other Languages,Specialized Needs Annexes,The GNAT Library,Top -@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{415}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{416}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11} +@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{418}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{419}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11} @chapter Interfacing to Other Languages @@ -25732,7 +25761,7 @@ provided. @end menu @node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{417}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{418} +@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{41a}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{41b} @section Interfacing to C @@ -25872,7 +25901,7 @@ of the length corresponding to the @code{type'Size} value in Ada. @end itemize @node Interfacing to C++,Interfacing to COBOL,Interfacing to C,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{49}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{419} +@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{49}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{41c} @section Interfacing to C++ @@ -26089,7 +26118,7 @@ builds an opaque @code{Type_Info_Ptr} to reference a @code{std::type_info} object at a given @code{System.Address}. @node Interfacing to COBOL,Interfacing to Fortran,Interfacing to C++,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{41a}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{41b} +@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{41d}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{41e} @section Interfacing to COBOL @@ -26097,7 +26126,7 @@ Interfacing to COBOL is achieved as described in section B.4 of the Ada Reference Manual. @node Interfacing to Fortran,Interfacing to non-GNAT Ada code,Interfacing to COBOL,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{41c}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{41d} +@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{41f}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{420} @section Interfacing to Fortran @@ -26107,7 +26136,7 @@ multi-dimensional array causes the array to be stored in column-major order as required for convenient interface to Fortran. @node Interfacing to non-GNAT Ada code,,Interfacing to Fortran,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{41e}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{41f} +@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{421}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{422} @section Interfacing to non-GNAT Ada code @@ -26131,7 +26160,7 @@ values or simple record types without variants, or simple array types with fixed bounds. @node Specialized Needs Annexes,Implementation of Specific Ada Features,Interfacing to Other Languages,Top -@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{420}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{421}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12} +@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{423}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{424}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12} @chapter Specialized Needs Annexes @@ -26172,7 +26201,7 @@ in Ada 2005) is fully implemented. @end table @node Implementation of Specific Ada Features,Implementation of Ada 2012 Features,Specialized Needs Annexes,Top -@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{422}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{423}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13} +@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{426}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13} @chapter Implementation of Specific Ada Features @@ -26191,7 +26220,7 @@ facilities. @end menu @node Machine Code Insertions,GNAT Implementation of Tasking,,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{424}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{17d} +@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{180} @section Machine Code Insertions @@ -26359,7 +26388,7 @@ according to normal visibility rules. In particular if there is no qualification is required. @node GNAT Implementation of Tasking,GNAT Implementation of Shared Passive Packages,Machine Code Insertions,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{426} +@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{428}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{429} @section GNAT Implementation of Tasking @@ -26375,7 +26404,7 @@ to compliance with the Real-Time Systems Annex. @end menu @node Mapping Ada Tasks onto the Underlying Kernel Threads,Ensuring Compliance with the Real-Time Annex,,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{428} +@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{42a}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{42b} @subsection Mapping Ada Tasks onto the Underlying Kernel Threads @@ -26444,7 +26473,7 @@ support this functionality when the parent contains more than one task. @geindex Forking a new process @node Ensuring Compliance with the Real-Time Annex,Support for Locking Policies,Mapping Ada Tasks onto the Underlying Kernel Threads,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{429}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{42a} +@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{42c}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{42d} @subsection Ensuring Compliance with the Real-Time Annex @@ -26495,7 +26524,7 @@ placed at the end. @c Support_for_Locking_Policies @node Support for Locking Policies,,Ensuring Compliance with the Real-Time Annex,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{42b} +@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{42e} @subsection Support for Locking Policies @@ -26529,7 +26558,7 @@ then ceiling locking is used. Otherwise, the @code{Ceiling_Locking} policy is ignored. @node GNAT Implementation of Shared Passive Packages,Code Generation for Array Aggregates,GNAT Implementation of Tasking,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{42c}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{42d} +@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{430} @section GNAT Implementation of Shared Passive Packages @@ -26627,7 +26656,7 @@ This is used to provide the required locking semantics for proper protected object synchronization. @node Code Generation for Array Aggregates,The Size of Discriminated Records with Default Discriminants,GNAT Implementation of Shared Passive Packages,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{42e}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{42f} +@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{431}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{432} @section Code Generation for Array Aggregates @@ -26658,7 +26687,7 @@ component values and static subtypes also lead to simpler code. @end menu @node Static constant aggregates with static bounds,Constant aggregates with unconstrained nominal types,,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{430}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{431} +@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{433}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{434} @subsection Static constant aggregates with static bounds @@ -26705,7 +26734,7 @@ Zero2: constant two_dim := (others => (others => 0)); @end example @node Constant aggregates with unconstrained nominal types,Aggregates with static bounds,Static constant aggregates with static bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{432}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{433} +@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{435}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{436} @subsection Constant aggregates with unconstrained nominal types @@ -26720,7 +26749,7 @@ Cr_Unc : constant One_Unc := (12,24,36); @end example @node Aggregates with static bounds,Aggregates with nonstatic bounds,Constant aggregates with unconstrained nominal types,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{434}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{435} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{437}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{438} @subsection Aggregates with static bounds @@ -26748,7 +26777,7 @@ end loop; @end example @node Aggregates with nonstatic bounds,Aggregates in assignment statements,Aggregates with static bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{436}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{437} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{439}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{43a} @subsection Aggregates with nonstatic bounds @@ -26759,7 +26788,7 @@ have to be applied to sub-arrays individually, if they do not have statically compatible subtypes. @node Aggregates in assignment statements,,Aggregates with nonstatic bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{438}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{439} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{43b}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{43c} @subsection Aggregates in assignment statements @@ -26801,7 +26830,7 @@ a temporary (created either by the front-end or the code generator) and then that temporary will be copied onto the target. @node The Size of Discriminated Records with Default Discriminants,Image Values For Nonscalar Types,Code Generation for Array Aggregates,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{43a}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{43b} +@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{43d}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{43e} @section The Size of Discriminated Records with Default Discriminants @@ -26881,7 +26910,7 @@ say) must be consistent, so it is imperative that the object, once created, remain invariant. @node Image Values For Nonscalar Types,Strict Conformance to the Ada Reference Manual,The Size of Discriminated Records with Default Discriminants,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{43c}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{43d} +@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{43f}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{440} @section Image Values For Nonscalar Types @@ -26901,7 +26930,7 @@ control of image text is required for some type T, then T’Put_Image should be explicitly specified. @node Strict Conformance to the Ada Reference Manual,,Image Values For Nonscalar Types,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id15}@anchor{43e}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{43f} +@anchor{gnat_rm/implementation_of_specific_ada_features id15}@anchor{441}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{442} @section Strict Conformance to the Ada Reference Manual @@ -26928,7 +26957,7 @@ behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. @node Implementation of Ada 2012 Features,GNAT language extensions,Implementation of Specific Ada Features,Top -@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{440}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{441}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14} +@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{443}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{444}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14} @chapter Implementation of Ada 2012 Features @@ -29094,7 +29123,7 @@ RM References: 4.03.01 (17) @end itemize @node GNAT language extensions,Security Hardening Features,Implementation of Ada 2012 Features,Top -@anchor{gnat_rm/gnat_language_extensions doc}@anchor{442}@anchor{gnat_rm/gnat_language_extensions gnat-language-extensions}@anchor{443}@anchor{gnat_rm/gnat_language_extensions id1}@anchor{444} +@anchor{gnat_rm/gnat_language_extensions doc}@anchor{445}@anchor{gnat_rm/gnat_language_extensions gnat-language-extensions}@anchor{446}@anchor{gnat_rm/gnat_language_extensions id1}@anchor{447} @chapter GNAT language extensions @@ -29126,7 +29155,7 @@ These features might be removed or heavily modified at any time. @end menu @node How to activate the extended GNAT Ada superset,Curated Extensions,,GNAT language extensions -@anchor{gnat_rm/gnat_language_extensions how-to-activate-the-extended-gnat-ada-superset}@anchor{445} +@anchor{gnat_rm/gnat_language_extensions how-to-activate-the-extended-gnat-ada-superset}@anchor{448} @section How to activate the extended GNAT Ada superset @@ -29167,7 +29196,7 @@ for use in playground experiments. @end cartouche @node Curated Extensions,Experimental Language Extensions,How to activate the extended GNAT Ada superset,GNAT language extensions -@anchor{gnat_rm/gnat_language_extensions curated-extensions}@anchor{446}@anchor{gnat_rm/gnat_language_extensions curated-language-extensions}@anchor{6a} +@anchor{gnat_rm/gnat_language_extensions curated-extensions}@anchor{449}@anchor{gnat_rm/gnat_language_extensions curated-language-extensions}@anchor{6a} @section Curated Extensions @@ -29188,7 +29217,7 @@ Features activated via @code{-gnatX} or @end menu @node Local Declarations Without Block,Deep delta Aggregates,,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions local-declarations-without-block}@anchor{447} +@anchor{gnat_rm/gnat_language_extensions local-declarations-without-block}@anchor{44a} @subsection Local Declarations Without Block @@ -29281,7 +29310,7 @@ And as such the second `@w{`}A`@w{`} declaration is hiding the first one. @end cartouche @node Deep delta Aggregates,Fixed lower bounds for array types and subtypes,Local Declarations Without Block,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions deep-delta-aggregates}@anchor{448} +@anchor{gnat_rm/gnat_language_extensions deep-delta-aggregates}@anchor{44b} @subsection Deep delta Aggregates @@ -29303,7 +29332,7 @@ The syntax of delta aggregates in the extended version is the following: @end menu @node Syntax,Legality Rules,,Deep delta Aggregates -@anchor{gnat_rm/gnat_language_extensions syntax}@anchor{449} +@anchor{gnat_rm/gnat_language_extensions syntax}@anchor{44c} @subsubsection Syntax @@ -29349,7 +29378,7 @@ array_subcomponent_choice ::= @end example @node Legality Rules,Dynamic Semantics,Syntax,Deep delta Aggregates -@anchor{gnat_rm/gnat_language_extensions legality-rules}@anchor{44a} +@anchor{gnat_rm/gnat_language_extensions legality-rules}@anchor{44d} @subsubsection Legality Rules @@ -29386,7 +29415,7 @@ the object denoted by the base_expression, prior to any update.] @end enumerate @node Dynamic Semantics,Examples,Legality Rules,Deep delta Aggregates -@anchor{gnat_rm/gnat_language_extensions dynamic-semantics}@anchor{44b} +@anchor{gnat_rm/gnat_language_extensions dynamic-semantics}@anchor{44e} @subsubsection Dynamic Semantics @@ -29443,7 +29472,7 @@ and assigned to the corresponding subcomponent of the anonymous object. @end itemize @node Examples,,Dynamic Semantics,Deep delta Aggregates -@anchor{gnat_rm/gnat_language_extensions examples}@anchor{44c} +@anchor{gnat_rm/gnat_language_extensions examples}@anchor{44f} @subsubsection Examples @@ -29471,7 +29500,7 @@ end; @end example @node Fixed lower bounds for array types and subtypes,Prefixed-view notation for calls to primitive subprograms of untagged types,Deep delta Aggregates,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{44d} +@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{450} @subsection Fixed lower bounds for array types and subtypes @@ -29522,7 +29551,7 @@ lower bound of unconstrained array formals when the formal’s subtype has index ranges with static fixed lower bounds. @node Prefixed-view notation for calls to primitive subprograms of untagged types,Expression defaults for generic formal functions,Fixed lower bounds for array types and subtypes,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{44e} +@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{451} @subsection Prefixed-view notation for calls to primitive subprograms of untagged types @@ -29572,7 +29601,7 @@ pragma Assert (V.Nth_Element(1) = 42); @end example @node Expression defaults for generic formal functions,String interpolation,Prefixed-view notation for calls to primitive subprograms of untagged types,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{44f} +@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{452} @subsection Expression defaults for generic formal functions @@ -29603,7 +29632,7 @@ If the default is used (i.e. there is no actual corresponding to Copy), then calls to Copy in the instance will simply return Item. @node String interpolation,Constrained attribute for generic objects,Expression defaults for generic formal functions,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{450} +@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{453} @subsection String interpolation @@ -29770,7 +29799,7 @@ a double quote is " and an open brace is @{ @end example @node Constrained attribute for generic objects,Static aspect on intrinsic functions,String interpolation,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{451} +@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{454} @subsection Constrained attribute for generic objects @@ -29778,7 +29807,7 @@ The @code{Constrained} attribute is permitted for objects of generic types. The result indicates whether the corresponding actual is constrained. @node Static aspect on intrinsic functions,First Controlling Parameter,Constrained attribute for generic objects,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{452} +@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{455} @subsection @code{Static} aspect on intrinsic functions @@ -29787,7 +29816,7 @@ and the compiler will evaluate some of these intrinsics statically, in particular the @code{Shift_Left} and @code{Shift_Right} intrinsics. @node First Controlling Parameter,,Static aspect on intrinsic functions,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions first-controlling-parameter}@anchor{453} +@anchor{gnat_rm/gnat_language_extensions first-controlling-parameter}@anchor{456} @subsection First Controlling Parameter @@ -29887,7 +29916,7 @@ The result of a function is never a controlling result. @end itemize @node Experimental Language Extensions,,Curated Extensions,GNAT language extensions -@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{6b}@anchor{gnat_rm/gnat_language_extensions id2}@anchor{454} +@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{6b}@anchor{gnat_rm/gnat_language_extensions id2}@anchor{457} @section Experimental Language Extensions @@ -29896,6 +29925,7 @@ Features activated via @code{-gnatX0} or @menu * Conditional when constructs:: +* Implicit With:: * Storage Model:: * Attribute Super:: * Simpler Accessibility Model:: @@ -29909,8 +29939,8 @@ Features activated via @code{-gnatX0} or @end menu -@node Conditional when constructs,Storage Model,,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{455} +@node Conditional when constructs,Implicit With,,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{458} @subsection Conditional when constructs @@ -29978,8 +30008,25 @@ begin end; @end example -@node Storage Model,Attribute Super,Conditional when constructs,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions storage-model}@anchor{456} +@node Implicit With,Storage Model,Conditional when constructs,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions implicit-with}@anchor{459} +@subsection Implicit With + + +This feature allows a standalone @code{use} clause in the context clause of a +compilation unit to imply an implicit @code{with} of the same library unit where +an equivalent @code{with} clause would be allowed. + +@example +use Ada.Text_IO; +procedure Main is +begin + Put_Line ("Hello"); +end; +@end example + +@node Storage Model,Attribute Super,Implicit With,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions storage-model}@anchor{45a} @subsection Storage Model @@ -29996,7 +30043,7 @@ memory models, in particular to support interactions with GPU. @end menu @node Aspect Storage_Model_Type,Aspect Designated_Storage_Model,,Storage Model -@anchor{gnat_rm/gnat_language_extensions aspect-storage-model-type}@anchor{457} +@anchor{gnat_rm/gnat_language_extensions aspect-storage-model-type}@anchor{45b} @subsubsection Aspect Storage_Model_Type @@ -30130,7 +30177,7 @@ end CUDA_Memory; @end example @node Aspect Designated_Storage_Model,Legacy Storage Pools,Aspect Storage_Model_Type,Storage Model -@anchor{gnat_rm/gnat_language_extensions aspect-designated-storage-model}@anchor{458} +@anchor{gnat_rm/gnat_language_extensions aspect-designated-storage-model}@anchor{45c} @subsubsection Aspect Designated_Storage_Model @@ -30208,7 +30255,7 @@ begin @end example @node Legacy Storage Pools,,Aspect Designated_Storage_Model,Storage Model -@anchor{gnat_rm/gnat_language_extensions legacy-storage-pools}@anchor{459} +@anchor{gnat_rm/gnat_language_extensions legacy-storage-pools}@anchor{45d} @subsubsection Legacy Storage Pools @@ -30259,7 +30306,7 @@ type Acc is access Integer_Array with Storage_Pool => My_Pool; can still be accepted as a shortcut for the new syntax. @node Attribute Super,Simpler Accessibility Model,Storage Model,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions attribute-super}@anchor{45a} +@anchor{gnat_rm/gnat_language_extensions attribute-super}@anchor{45e} @subsection Attribute Super @@ -30294,7 +30341,7 @@ end; @end example @node Simpler Accessibility Model,Case pattern matching,Attribute Super,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{45b} +@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{45f} @subsection Simpler Accessibility Model @@ -30325,7 +30372,7 @@ All of the refined rules are compatible with the [use of anonymous access types @end menu @node Stand-alone objects,Subprogram parameters,,Simpler Accessibility Model -@anchor{gnat_rm/gnat_language_extensions stand-alone-objects}@anchor{45c} +@anchor{gnat_rm/gnat_language_extensions stand-alone-objects}@anchor{460} @subsubsection Stand-alone objects @@ -30373,7 +30420,7 @@ of the RM 4.6 rule “The accessibility level of the operand type shall not be statically deeper than that of the target type …”. @node Subprogram parameters,Function results,Stand-alone objects,Simpler Accessibility Model -@anchor{gnat_rm/gnat_language_extensions subprogram-parameters}@anchor{45d} +@anchor{gnat_rm/gnat_language_extensions subprogram-parameters}@anchor{461} @subsubsection Subprogram parameters @@ -30466,7 +30513,7 @@ end; @end example @node Function results,,Subprogram parameters,Simpler Accessibility Model -@anchor{gnat_rm/gnat_language_extensions function-results}@anchor{45e} +@anchor{gnat_rm/gnat_language_extensions function-results}@anchor{462} @subsubsection Function results @@ -30594,7 +30641,7 @@ end; @end example @node Case pattern matching,Mutably Tagged Types with Size’Class Aspect,Simpler Accessibility Model,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{45f} +@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{463} @subsection Case pattern matching @@ -30724,7 +30771,7 @@ message generated in such cases is usually “Capacity exceeded in compiling case statement with composite selector type”. @node Mutably Tagged Types with Size’Class Aspect,Generalized Finalization,Case pattern matching,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{460} +@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{464} @subsection Mutably Tagged Types with Size’Class Aspect @@ -30855,7 +30902,7 @@ parameter exists (that is, before leaving the corresponding callable construct). @node Generalized Finalization,No_Raise aspect,Mutably Tagged Types with Size’Class Aspect,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{461} +@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{465} @subsection Generalized Finalization @@ -30926,7 +30973,7 @@ hence `not' be deallocated either. The result is simply that memory will be leaked in those cases. @item -The @code{Finalize} procedure should have have the @ref{462,,No_Raise aspect} specified. +The @code{Finalize} procedure should have have the @ref{466,,No_Raise aspect} specified. If that’s not the case, a compilation error will be raised. @end itemize @@ -30946,7 +30993,7 @@ heap-allocated objects @end itemize @node No_Raise aspect,Inference of Dependent Types in Generic Instantiations,Generalized Finalization,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions id3}@anchor{463}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{462} +@anchor{gnat_rm/gnat_language_extensions id3}@anchor{467}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{466} @subsection No_Raise aspect @@ -30963,7 +31010,7 @@ this subprogram, @code{Program_Error} is raised. @end menu @node New specification for Ada Finalization Controlled,Finalized tagged types,,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions new-specification-for-ada-finalization-controlled}@anchor{464} +@anchor{gnat_rm/gnat_language_extensions new-specification-for-ada-finalization-controlled}@anchor{468} @subsubsection New specification for @code{Ada.Finalization.Controlled} @@ -31030,7 +31077,7 @@ private @end example @node Finalized tagged types,Composite types,New specification for Ada Finalization Controlled,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions finalized-tagged-types}@anchor{465} +@anchor{gnat_rm/gnat_language_extensions finalized-tagged-types}@anchor{469} @subsubsection Finalized tagged types @@ -31043,7 +31090,7 @@ However note that for simplicity, it is forbidden to change the value of any of those new aspects in derived types. @node Composite types,Interoperability with controlled types,Finalized tagged types,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{466} +@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{46a} @subsubsection Composite types @@ -31060,7 +31107,7 @@ are called on the composite object, but @code{Finalize} is called on the compos object first. @node Interoperability with controlled types,,Composite types,No_Raise aspect -@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{467} +@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{46b} @subsubsection Interoperability with controlled types @@ -31081,7 +31128,7 @@ component @end itemize @node Inference of Dependent Types in Generic Instantiations,External_Initialization Aspect,No_Raise aspect,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{468} +@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{46c} @subsection Inference of Dependent Types in Generic Instantiations @@ -31158,7 +31205,7 @@ package Int_Array_Operations is new Array_Operations @end example @node External_Initialization Aspect,Finally construct,Inference of Dependent Types in Generic Instantiations,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{469} +@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{46d} @subsection External_Initialization Aspect @@ -31199,7 +31246,7 @@ The maximum size of loaded files is limited to 2@w{^31} bytes. @end cartouche @node Finally construct,,External_Initialization Aspect,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions finally-construct}@anchor{46a} +@anchor{gnat_rm/gnat_language_extensions finally-construct}@anchor{46e} @subsection Finally construct @@ -31216,7 +31263,7 @@ This feature is similar to the one with the same name in other languages such as @end menu @node Syntax<2>,Legality Rules<2>,,Finally construct -@anchor{gnat_rm/gnat_language_extensions id4}@anchor{46b} +@anchor{gnat_rm/gnat_language_extensions id4}@anchor{46f} @subsubsection Syntax @@ -31231,7 +31278,7 @@ handled_sequence_of_statements ::= @end example @node Legality Rules<2>,Dynamic Semantics<2>,Syntax<2>,Finally construct -@anchor{gnat_rm/gnat_language_extensions id5}@anchor{46c} +@anchor{gnat_rm/gnat_language_extensions id5}@anchor{470} @subsubsection Legality Rules @@ -31241,7 +31288,7 @@ to be transferred outside the finally part are forbidden. Goto & exit where the target is outside of the finally’s @code{sequence_of_statements} are forbidden @node Dynamic Semantics<2>,,Legality Rules<2>,Finally construct -@anchor{gnat_rm/gnat_language_extensions id6}@anchor{46d} +@anchor{gnat_rm/gnat_language_extensions id6}@anchor{471} @subsubsection Dynamic Semantics @@ -31256,7 +31303,7 @@ execution, that is the finally block must be executed in full even if the contai aborted, or if the control is transferred out of the block. @node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top -@anchor{gnat_rm/security_hardening_features doc}@anchor{46e}@anchor{gnat_rm/security_hardening_features id1}@anchor{46f}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@anchor{gnat_rm/security_hardening_features doc}@anchor{472}@anchor{gnat_rm/security_hardening_features id1}@anchor{473}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} @chapter Security Hardening Features @@ -31278,7 +31325,7 @@ change. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{470} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{474} @section Register Scrubbing @@ -31314,7 +31361,7 @@ programming languages, see @cite{Using the GNU Compiler Collection (GCC)}. @c Stack Scrubbing: @node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{471} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{475} @section Stack Scrubbing @@ -31458,7 +31505,7 @@ Bar_Callable_Ptr. @c Hardened Conditionals: @node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{472} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{476} @section Hardened Conditionals @@ -31548,7 +31595,7 @@ be used with other programming languages supported by GCC. @c Hardened Booleans: @node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{473} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{477} @section Hardened Booleans @@ -31609,7 +31656,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection @c Control Flow Redundancy: @node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features -@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{474} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{478} @section Control Flow Redundancy @@ -31777,7 +31824,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}. These options can be used with other programming languages supported by GCC. @node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top -@anchor{gnat_rm/obsolescent_features doc}@anchor{475}@anchor{gnat_rm/obsolescent_features id1}@anchor{476}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} +@anchor{gnat_rm/obsolescent_features doc}@anchor{479}@anchor{gnat_rm/obsolescent_features id1}@anchor{47a}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -31796,7 +31843,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{477}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{478} +@anchor{gnat_rm/obsolescent_features id2}@anchor{47b}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{47c} @section pragma No_Run_Time @@ -31809,7 +31856,7 @@ preferred usage is to use an appropriately configured run-time that includes just those features that are to be made accessible. @node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id3}@anchor{479}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{47a} +@anchor{gnat_rm/obsolescent_features id3}@anchor{47d}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{47e} @section pragma Ravenscar @@ -31818,7 +31865,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma is part of the new Ada 2005 standard. @node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id4}@anchor{47b}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{47c} +@anchor{gnat_rm/obsolescent_features id4}@anchor{47f}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{480} @section pragma Restricted_Run_Time @@ -31828,7 +31875,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for this kind of implementation dependent addition. @node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id5}@anchor{47d}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{47e} +@anchor{gnat_rm/obsolescent_features id5}@anchor{481}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{482} @section pragma Task_Info @@ -31854,7 +31901,7 @@ in the spec of package System.Task_Info in the runtime library. @node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features -@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{47f}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{480} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{483}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{484} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -31864,7 +31911,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package standard replacement for GNAT’s @code{Task_Info} functionality. @node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top -@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{481}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{482} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{485}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{486} @chapter Compatibility and Porting Guide @@ -31886,7 +31933,7 @@ applications developed in other Ada environments. @end menu @node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{483}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{484} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{488} @section Writing Portable Fixed-Point Declarations @@ -32008,7 +32055,7 @@ If you follow this scheme you will be guaranteed that your fixed-point types will be portable. @node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{485}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{486} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{48a} @section Compatibility with Ada 83 @@ -32036,7 +32083,7 @@ following subsections treat the most likely issues to be encountered. @end menu @node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{488} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48c} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -32136,7 +32183,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration. @end itemize @node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{48a} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{48e} @subsection More deterministic semantics @@ -32164,7 +32211,7 @@ which open select branches are executed. @end itemize @node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{48c} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{48f}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{490} @subsection Changed semantics @@ -32206,7 +32253,7 @@ covers only the restricted range. @end itemize @node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{48e} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{492} @subsection Other language compatibility issues @@ -32239,7 +32286,7 @@ include @code{pragma Interface} and the floating point type attributes @end itemize @node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{48f}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{490} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{494} @section Compatibility between Ada 95 and Ada 2005 @@ -32311,7 +32358,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{492} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{495}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{496} @section Implementation-dependent characteristics @@ -32334,7 +32381,7 @@ transition from certain Ada 83 compilers. @end menu @node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{494} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{497}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{498} @subsection Implementation-defined pragmas @@ -32356,7 +32403,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not relevant in a GNAT context and hence are not otherwise implemented. @node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{495}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{496} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{499}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{49a} @subsection Implementation-defined attributes @@ -32370,7 +32417,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and @code{Type_Class}. @node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{497}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{498} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{49b}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{49c} @subsection Libraries @@ -32399,7 +32446,7 @@ be preferable to retrofit the application using modular types. @end itemize @node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{499}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{49a} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{49d}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{49e} @subsection Elaboration order @@ -32435,7 +32482,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{49b}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{49c} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{49f}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{4a0} @subsection Target-specific aspects @@ -32448,10 +32495,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus Ada 2005 and Ada 2012) are sometimes incompatible with typical Ada 83 compiler practices regarding implicit packing, the meaning of the Size attribute, and the size of access values. -GNAT’s approach to these issues is described in @ref{49d,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{4a1,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{49e}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{49f} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{4a2}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{4a3} @section Compatibility with Other Ada Systems @@ -32494,7 +32541,7 @@ far beyond this minimal set, as described in the next section. @end itemize @node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{4a0}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{49d} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{4a4}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{4a1} @section Representation Clauses @@ -32587,7 +32634,7 @@ with thin pointers. @end itemize @node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{4a1}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4a2} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{4a5}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4a6} @section Compatibility with HP Ada 83 @@ -32617,7 +32664,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license doc}@anchor{4a3}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4a4} +@anchor{share/gnu_free_documentation_license doc}@anchor{4a7}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4a8} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 2579b31..ca1d7bc 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3,7 +3,7 @@ @setfilename gnat_ugn.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 8.0.2.@* +@*Generated by Sphinx 8.2.3.@* @end ifinfo @settitle GNAT User's Guide for Native Platforms @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Jan 13, 2025 +GNAT User's Guide for Native Platforms , Jun 02, 2025 AdaCore @@ -25582,11 +25582,12 @@ the breakpoint we have set. From there you can use standard You can specify the program stack size at link time. On most versions of Windows, starting with XP, this is mostly useful to set the size of the main stack (environment task). The other task stacks are set with -pragma Storage_Size or with the `gnatbind -d' command. +pragma Storage_Size or with the `gnatbind -d' command. The specified size will +become the reserved memory size of the underlying thread. Since very old versions of Windows (2000, NT4, etc.) don’t allow setting the -reserve size of individual tasks, the link-time stack size applies to all -tasks, and pragma Storage_Size has no effect. +reserve size of individual tasks, for those versions the link-time stack size +applies to all tasks, and pragma Storage_Size has no effect. In particular, Stack Overflow checks are made against this link-time specified size. @@ -29832,8 +29833,8 @@ to permit their use in free software. @printindex ge -@anchor{d2}@w{ } @anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } +@anchor{d2}@w{ } @c %**end of body @bye diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 4e549a9..6fa2327 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -1605,7 +1605,9 @@ procedure Gnatls is Name_Len := 0; if not Is_Absolute_Path (Self (First .. Last)) then - Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call + Add_Str_To_Name_Buffer + (GNAT.Directory_Operations.Get_Current_Dir); + Add_Char_To_Name_Buffer (Directory_Separator); end if; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 494f1f8..abb49b5 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -320,6 +320,7 @@ package body Inline is -- Exit_Cases -- Postcondition -- Precondition + -- Program_Exit -- Refined_Global -- Refined_Depends -- Refined_Post @@ -4077,6 +4078,7 @@ package body Inline is -- Replace call with temporary and create its declaration Temp := Make_Temporary (Loc, 'C'); + Mutate_Ekind (Temp, E_Constant); Set_Is_Internal (Temp); -- For the unconstrained case, the generated temporary has the @@ -5271,6 +5273,7 @@ package body Inline is | Name_Exit_Cases | Name_Postcondition | Name_Precondition + | Name_Program_Exit | Name_Refined_Global | Name_Refined_Depends | Name_Refined_Post diff --git a/gcc/ada/diagnostics-json_utils.adb b/gcc/ada/json_utils.adb index 072cab4..61b0693 100644 --- a/gcc/ada/diagnostics-json_utils.adb +++ b/gcc/ada/json_utils.adb @@ -22,9 +22,13 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + +with Namet; use Namet; +with Osint; with Output; use Output; +with System.OS_Lib; -package body Diagnostics.JSON_Utils is +package body JSON_Utils is ----------------- -- Begin_Block -- @@ -64,6 +68,141 @@ package body Diagnostics.JSON_Utils is end if; end NL_And_Indent; + ----------------- + -- To_File_Uri -- + ----------------- + + function To_File_Uri (Path : String) return String is + + function Normalize_Uri (Path : String) return String; + -- Construct a normalized URI from the path name by replacing reserved + -- URI characters that can appear in paths with their escape character + -- combinations. + -- + -- According to the URI standard reserved charcthers within the paths + -- should be percent encoded: + -- + -- https://www.rfc-editor.org/info/rfc3986 + -- + -- Reserved charcters are defined as: + -- + -- reserved = gen-delims / sub-delims + -- gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" + -- sub-delims = "!" / "$" / "&" / "’" / "(" / ")" + -- / "*" / "+" / "," / ";" / "=" + + ------------------- + -- Normalize_Uri -- + ------------------- + + function Normalize_Uri (Path : String) return String is + Buf : Bounded_String; + begin + for C of Path loop + case C is + when '\' => + + -- Use forward slashes instead of backward slashes as + -- separators on Windows and on Linux simply encode the + -- symbol if part of a directory name. + + if Osint.On_Windows then + Append (Buf, '/'); + else + Append (Buf, "%5C"); + end if; + + when ' ' => + Append (Buf, "%20"); + + when '!' => + Append (Buf, "%21"); + + when '#' => + Append (Buf, "%23"); + + when '$' => + Append (Buf, "%24"); + + when '&' => + Append (Buf, "%26"); + + when ''' => + Append (Buf, "%27"); + + when '(' => + Append (Buf, "%28"); + + when ')' => + Append (Buf, "%29"); + + when '*' => + Append (Buf, "%2A"); + + when '+' => + Append (Buf, "%2A"); + + when ',' => + Append (Buf, "%2A"); + + when '/' => + -- Forward slash is a valid file separator on both Unix and + -- Windows based machines and should be treated as such + -- within a path. + Append (Buf, '/'); + + when ':' => + Append (Buf, "%3A"); + + when ';' => + Append (Buf, "%3B"); + + when '=' => + Append (Buf, "%3D"); + + when '?' => + Append (Buf, "%3F"); + + when '@' => + Append (Buf, "%40"); + + when '[' => + Append (Buf, "%5B"); + + when ']' => + Append (Buf, "%5D"); + + when others => + Append (Buf, C); + end case; + end loop; + + return To_String (Buf); + end Normalize_Uri; + + Norm_Uri : constant String := Normalize_Uri (Path); + + -- Start of processing for To_File_Uri + + begin + if System.OS_Lib.Is_Absolute_Path (Path) then + -- URI-s using the file scheme should start with the following + -- prefix: + -- + -- "file:///" + + if Osint.On_Windows then + return "file:///" & Norm_Uri; + else + -- Full paths on linux based systems already start with '/' + + return "file://" & Norm_Uri; + end if; + else + return Norm_Uri; + end if; + end To_File_Uri; + ----------------------------- -- Write_Boolean_Attribute -- ----------------------------- @@ -112,4 +251,4 @@ package body Diagnostics.JSON_Utils is Write_Char ('"'); end Write_String_Attribute; -end Diagnostics.JSON_Utils; +end JSON_Utils; diff --git a/gcc/ada/diagnostics-json_utils.ads b/gcc/ada/json_utils.ads index 526e09e..b251def 100644 --- a/gcc/ada/diagnostics-json_utils.ads +++ b/gcc/ada/json_utils.ads @@ -22,8 +22,9 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ +with Types; use Types; -package Diagnostics.JSON_Utils is +package JSON_Utils is JSON_FORMATTING : constant Boolean := True; -- Adds newlines and indentation to the output JSON. @@ -49,6 +50,11 @@ package Diagnostics.JSON_Utils is procedure NL_And_Indent; -- Print a new line + function To_File_Uri (Path : String) return String; + -- Converts an absolute Path into a file URI string by adding the file + -- schema prefix "file:///" and replacing all of the URI reserved + -- characters in the absolute path. + procedure Write_Boolean_Attribute (Name : String; Value : Boolean); -- Write a JSON attribute with a boolean value. -- @@ -72,4 +78,4 @@ package Diagnostics.JSON_Utils is -- The Value is surrounded by double quotes ("") and the special characters -- within the string are escaped. -end Diagnostics.JSON_Utils; +end JSON_Utils; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 46de911..bdeea1c 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -226,13 +226,11 @@ package body Lib.Load is Fatal_Error => Error_Detected, Generate_Code => False, Has_RACW => False, - Filler => False, Ident_String => Empty, Is_Predefined_Renaming => Ren_Name, Is_Predefined_Unit => Pre_Name or Ren_Name, Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name, - Filler2 => False, Loading => False, Main_Priority => Default_Main_Priority, @@ -374,13 +372,11 @@ package body Lib.Load is Fatal_Error => None, Generate_Code => True, Has_RACW => False, - Filler => False, Ident_String => Empty, Is_Predefined_Renaming => Ren_Name, Is_Predefined_Unit => Pre_Name or Ren_Name, Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name, - Filler2 => False, Loading => True, Main_Priority => Default_Main_Priority, @@ -760,13 +756,11 @@ package body Lib.Load is Fatal_Error => None, Generate_Code => False, Has_RACW => False, - Filler => False, Ident_String => Empty, Is_Predefined_Renaming => Ren_Name, Is_Predefined_Unit => Pre_Name or Ren_Name, Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name, - Filler2 => False, Loading => True, Main_Priority => Default_Main_Priority, diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index ccb0bd2..b7a7f12 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -116,12 +116,10 @@ package body Lib.Writ is Fatal_Error => None, Generate_Code => False, Has_RACW => False, - Filler => False, Ident_String => Empty, Is_Predefined_Renaming => False, Is_Internal_Unit => False, Is_Predefined_Unit => False, - Filler2 => False, Loading => False, Main_Priority => -1, Main_CPU => -1, @@ -175,12 +173,10 @@ package body Lib.Writ is Fatal_Error => None, Generate_Code => False, Has_RACW => False, - Filler => False, Ident_String => Empty, Is_Predefined_Renaming => False, Is_Internal_Unit => True, Is_Predefined_Unit => True, - Filler2 => False, Loading => False, Main_Priority => -1, Main_CPU => -1, diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index c902ca2..c22db30 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -871,55 +871,14 @@ private Has_RACW : Boolean; Dynamic_Elab : Boolean; No_Elab_Code_All : Boolean; - Filler : Boolean; Loading : Boolean; OA_Setting : Character; Is_Predefined_Renaming : Boolean; Is_Internal_Unit : Boolean; Is_Predefined_Unit : Boolean; - Filler2 : Boolean; end record; - -- The following representation clause ensures that the above record - -- has no holes. We do this so that when instances of this record are - -- written by Tree_Gen, we do not write uninitialized values to the file. - - for Unit_Record use record - Unit_File_Name at 0 range 0 .. 31; - Unit_Name at 4 range 0 .. 31; - Munit_Index at 8 range 0 .. 31; - Expected_Unit at 12 range 0 .. 31; - Source_Index at 16 range 0 .. 31; - Cunit at 20 range 0 .. 31; - Cunit_Entity at 24 range 0 .. 31; - Dependency_Num at 28 range 0 .. 31; - Ident_String at 32 range 0 .. 31; - Main_Priority at 36 range 0 .. 31; - Main_CPU at 40 range 0 .. 31; - Primary_Stack_Count at 44 range 0 .. 31; - Sec_Stack_Count at 48 range 0 .. 31; - Serial_Number at 52 range 0 .. 31; - Version at 56 range 0 .. 31; - Error_Location at 60 range 0 .. 31; - Fatal_Error at 64 range 0 .. 7; - Generate_Code at 65 range 0 .. 7; - Has_RACW at 66 range 0 .. 7; - Dynamic_Elab at 67 range 0 .. 7; - No_Elab_Code_All at 68 range 0 .. 7; - Filler at 69 range 0 .. 7; - OA_Setting at 70 range 0 .. 7; - Loading at 71 range 0 .. 7; - - Is_Predefined_Renaming at 72 range 0 .. 7; - Is_Internal_Unit at 73 range 0 .. 7; - Is_Predefined_Unit at 74 range 0 .. 7; - Filler2 at 75 range 0 .. 7; - end record; - - for Unit_Record'Size use 76 * 8; - -- This ensures that we did not leave out any fields - package Units is new Table.Table ( Table_Component_Type => Unit_Record, Table_Index_Type => Unit_Number_Type, diff --git a/gcc/ada/libgnarl/s-linux__android-aarch64.ads b/gcc/ada/libgnarl/s-linux__android-aarch64.ads index 4f9e81d..537c46b 100644 --- a/gcc/ada/libgnarl/s-linux__android-aarch64.ads +++ b/gcc/ada/libgnarl/s-linux__android-aarch64.ads @@ -118,13 +118,19 @@ package System.Linux is SIG33 : constant := 33; -- glibc internal signal SIG34 : constant := 34; -- glibc internal signal - -- struct_sigaction offsets - - -- sa_flags come first on aarch64-android (sa_flags, sa_handler, sa_mask) - - sa_flags_pos : constant := 0; - sa_handler_pos : constant := sa_flags_pos + Interfaces.C.int'Size / 8; - sa_mask_pos : constant := sa_handler_pos + Standard'Address_Size / 8; + -- struct_sigaction + + generic + type sigset_t is private; + package Android_Sigaction is + type struct_sigaction is record + sa_flags : Interfaces.C.int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_restorer : System.Address; + end record; + pragma Convention (C, struct_sigaction); + end Android_Sigaction; SA_SIGINFO : constant := 16#00000004#; SA_ONSTACK : constant := 16#08000000#; diff --git a/gcc/ada/libgnarl/s-linux__android-arm.ads b/gcc/ada/libgnarl/s-linux__android-arm.ads index 3e0325e..07bca55 100644 --- a/gcc/ada/libgnarl/s-linux__android-arm.ads +++ b/gcc/ada/libgnarl/s-linux__android-arm.ads @@ -118,11 +118,19 @@ package System.Linux is SIG33 : constant := 33; -- glibc internal signal SIG34 : constant := 34; -- glibc internal signal - -- struct_sigaction offsets - - sa_handler_pos : constant := 0; - sa_mask_pos : constant := Standard'Address_Size / 8; - sa_flags_pos : constant := 4 + sa_mask_pos; + -- struct_sigaction + + generic + type sigset_t is private; + package Android_Sigaction is + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : Interfaces.C.int; + sa_restorer : System.Address; + end record; + pragma Convention (C, struct_sigaction); + end Android_Sigaction; SA_SIGINFO : constant := 16#00000004#; SA_ONSTACK : constant := 16#08000000#; diff --git a/gcc/ada/libgnarl/s-osinte__android.ads b/gcc/ada/libgnarl/s-osinte__android.ads index cd7e148..4383860 100644 --- a/gcc/ada/libgnarl/s-osinte__android.ads +++ b/gcc/ada/libgnarl/s-osinte__android.ads @@ -147,7 +147,20 @@ package System.OS_Interface is -- Not clear why these two signals are reserved. Perhaps they are not -- supported by this version of GNU/Linux ??? - type sigset_t is private; + -- struct sigaction fields are of different sizes and come in different + -- order on ARM vs aarch64. As this source is shared by the two + -- configurations, fetch the type definition through System.Linux, which + -- is specialized. + + type sigset_t is + array (0 .. OS_Constants.SIZEOF_sigset - 1) of Interfaces.C.unsigned_char; + pragma Convention (C, sigset_t); + for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + package Android_Sigaction is new + System.Linux.Android_Sigaction (sigset_t => sigset_t); + + type struct_sigaction is new Android_Sigaction.struct_sigaction; function sigaddset (set : access sigset_t; sig : Signal) return int; pragma Import (C, sigaddset, "_sigaddset"); @@ -173,14 +186,6 @@ package System.OS_Interface is end record; pragma Convention (C, siginfo_t); - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : Interfaces.C.int; - sa_restorer : System.Address; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; SA_SIGINFO : constant := System.Linux.SA_SIGINFO; @@ -258,6 +263,14 @@ package System.OS_Interface is function getpid return pid_t; pragma Import (C, getpid, "getpid"); + PR_SET_NAME : constant := 15; + PR_GET_NAME : constant := 16; + + function prctl + (option : int; + arg : unsigned_long) return int; + pragma Import (C_Variadic_1, prctl, "prctl"); + ------------- -- Threads -- ------------- @@ -276,9 +289,11 @@ package System.OS_Interface is new Ada.Unchecked_Conversion (unsigned_long, pthread_t); subtype pthread_mutex_t is System.OS_Locks.pthread_mutex_t; + type pthread_rwlock_t is limited private; type pthread_cond_t is limited private; type pthread_attr_t is limited private; type pthread_mutexattr_t is limited private; + type pthread_rwlockattr_t is limited private; type pthread_condattr_t is limited private; type pthread_key_t is private; @@ -287,11 +302,6 @@ package System.OS_Interface is PTHREAD_SCOPE_PROCESS : constant := 1; PTHREAD_SCOPE_SYSTEM : constant := 0; - -- Read/Write lock not supported on Android. - - subtype pthread_rwlock_t is pthread_mutex_t; - subtype pthread_rwlockattr_t is pthread_mutexattr_t; - ----------- -- Stack -- ----------- @@ -389,6 +399,43 @@ package System.OS_Interface is function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + function pthread_rwlockattr_init + (attr : access pthread_rwlockattr_t) return int; + pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init"); + + function pthread_rwlockattr_destroy + (attr : access pthread_rwlockattr_t) return int; + pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy"); + + PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0; + PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 1; + + -- No PTHREAD_RWLOCK_PREFER_WRITER_NP in Android's pthread.h API level 29 + + function pthread_rwlockattr_setkind_np + (attr : access pthread_rwlockattr_t; + pref : int) return int; + pragma Import + (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np"); + + function pthread_rwlock_init + (mutex : access pthread_rwlock_t; + attr : access pthread_rwlockattr_t) return int; + pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init"); + + function pthread_rwlock_destroy + (mutex : access pthread_rwlock_t) return int; + pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy"); + + function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int; + pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock"); + + function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int; + pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock"); + + function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int; + pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock"); + function pthread_condattr_init (attr : access pthread_condattr_t) return int; pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); @@ -581,23 +628,6 @@ package System.OS_Interface is private - type sigset_t is - array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char; - pragma Convention (C, sigset_t); - for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; - - pragma Warnings (Off); - for struct_sigaction use record - sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1; - sa_mask at Linux.sa_mask_pos - range 0 .. OS_Constants.SIZEOF_sigset * 8 - 1; - sa_flags at Linux.sa_flags_pos - range 0 .. Interfaces.C.int'Size - 1; - end record; - -- We intentionally leave sa_restorer unspecified and let the compiler - -- append it after the last field, so disable corresponding warning. - pragma Warnings (On); - type pid_t is new int; type time_t is range -2 ** (System.Parameters.time_t_bits - 1) @@ -632,6 +662,18 @@ private pragma Convention (C, pthread_mutexattr_t); for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment; + type pthread_rwlockattr_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE); + end record; + pragma Convention (C, pthread_rwlockattr_t); + for pthread_rwlockattr_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + type pthread_rwlock_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCK_SIZE); + end record; + pragma Convention (C, pthread_rwlock_t); + for pthread_rwlock_t'Alignment use Interfaces.C.unsigned_long'Alignment; + type pthread_cond_t is record Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE); end record; diff --git a/gcc/ada/libgnat/a-nbnbig.adb b/gcc/ada/libgnat/a-nbnbig.adb deleted file mode 100644 index e487a05..0000000 --- a/gcc/ada/libgnat/a-nbnbig.adb +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS_GHOST -- --- -- --- B o d y -- --- -- --- Copyright (C) 2021-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This body is provided as a work-around for a GNAT compiler bug, as GNAT --- currently does not compile instantiations of the spec with imported ghost --- generics for packages Signed_Conversions and Unsigned_Conversions. - --- Ghost code in this unit is meant for analysis only, not for run-time --- checking. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore); - -package body Ada.Numerics.Big_Numbers.Big_Integers_Ghost with - SPARK_Mode => Off -is - - package body Signed_Conversions with - SPARK_Mode => Off - is - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer is - begin - raise Program_Error; - return (null record); - end To_Big_Integer; - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int is - begin - raise Program_Error; - return 0; - end From_Big_Integer; - - end Signed_Conversions; - - package body Unsigned_Conversions with - SPARK_Mode => Off - is - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer is - begin - raise Program_Error; - return (null record); - end To_Big_Integer; - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int is - begin - raise Program_Error; - return 0; - end From_Big_Integer; - - end Unsigned_Conversions; - -end Ada.Numerics.Big_Numbers.Big_Integers_Ghost; diff --git a/gcc/ada/libgnat/a-nbnbig.ads b/gcc/ada/libgnat/a-nbnbig.ads deleted file mode 100644 index 04aa62a..0000000 --- a/gcc/ada/libgnat/a-nbnbig.ads +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS_GHOST -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a reduced and non-executable implementation of the --- ARM A.5.6 defined ``Ada.Numerics.Big_Numbers.Big_Integers`` for use in --- SPARK proofs in the runtime. As it is only intended for SPARK proofs, this --- package is marked as a Ghost package and consequently does not have a --- runtime footprint. - --- Contrary to Ada.Numerics.Big_Numbers.Big_Integers, this unit does not --- depend on System or Ada.Finalization, which makes it more convenient for --- use in run-time units. Note, since it is a ghost unit, all subprograms are --- marked as imported. - --- Ghost code in this unit is meant for analysis only, not for run-time --- checking. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore); - -package Ada.Numerics.Big_Numbers.Big_Integers_Ghost with - SPARK_Mode, - Ghost, - Pure, - Always_Terminates -is - - type Big_Integer is private - with Integer_Literal => From_Universal_Image; - -- Private type that holds the integer value - - function Is_Valid (Arg : Big_Integer) return Boolean - with - Import, - Global => null; - -- Return whether a passed big integer is valid - - subtype Valid_Big_Integer is Big_Integer - with Dynamic_Predicate => Is_Valid (Valid_Big_Integer), - Predicate_Failure => raise Program_Error; - -- Holds a valid Big_Integer - - -- Comparison operators defined for valid Big_Integer values - function "=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function "<" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function "<=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function ">" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function ">=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function To_Big_Integer (Arg : Integer) return Valid_Big_Integer - with - Import, - Global => null; - -- Create a Big_Integer from an Integer value - - subtype Big_Positive is Big_Integer - with Dynamic_Predicate => - (if Is_Valid (Big_Positive) - then Big_Positive > To_Big_Integer (0)), - Predicate_Failure => raise Constraint_Error; - -- Positive subtype of Big_Integers, analogous to Positive and Integer - - subtype Big_Natural is Big_Integer - with Dynamic_Predicate => - (if Is_Valid (Big_Natural) - then Big_Natural >= To_Big_Integer (0)), - Predicate_Failure => raise Constraint_Error; - -- Natural subtype of Big_Integers, analogous to Natural and Integer - - function In_Range - (Arg : Valid_Big_Integer; Low, High : Big_Integer) return Boolean - is (Low <= Arg and Arg <= High) - with - Import, - Global => null; - -- Check whether Arg is in the range Low .. High - - function To_Integer (Arg : Valid_Big_Integer) return Integer - with - Import, - Pre => In_Range (Arg, - Low => To_Big_Integer (Integer'First), - High => To_Big_Integer (Integer'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into an Integer - - generic - type Int is range <>; - package Signed_Conversions is - -- Generic package to implement conversion functions for - -- arbitrary ranged types. - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer - with - Global => null; - -- Convert a ranged type into a valid Big_Integer - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int - with - Pre => In_Range (Arg, - Low => To_Big_Integer (Int'First), - High => To_Big_Integer (Int'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into a ranged type - end Signed_Conversions; - - generic - type Int is mod <>; - package Unsigned_Conversions is - -- Generic package to implement conversion functions for - -- arbitrary modular types. - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer - with - Global => null; - -- Convert a modular type into a valid Big_Integer - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int - with - Pre => In_Range (Arg, - Low => To_Big_Integer (Int'First), - High => To_Big_Integer (Int'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into a modular type - - end Unsigned_Conversions; - - function From_String (Arg : String) return Valid_Big_Integer - with - Import, - Global => null; - -- Create a valid Big_Integer from a String - - function From_Universal_Image (Arg : String) return Valid_Big_Integer - renames From_String; - - -- Mathematical operators defined for valid Big_Integer values - function "+" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "-" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "**" (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer - with - Import, - Global => null; - - function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function Greatest_Common_Divisor - (L, R : Valid_Big_Integer) return Big_Positive - with - Import, - Pre => (L /= To_Big_Integer (0) and R /= To_Big_Integer (0)) - or else raise Constraint_Error, - Global => null; - -- Calculate the greatest common divisor for two Big_Integer values - -private - pragma SPARK_Mode (Off); - - type Big_Integer is null record; - -- Solely consists of Ghost code - -end Ada.Numerics.Big_Numbers.Big_Integers_Ghost; diff --git a/gcc/ada/libgnat/a-nudira.ads b/gcc/ada/libgnat/a-nudira.ads index 647470b..3b2ca18 100644 --- a/gcc/ada/libgnat/a-nudira.ads +++ b/gcc/ada/libgnat/a-nudira.ads @@ -44,38 +44,60 @@ generic type Result_Subtype is (<>); package Ada.Numerics.Discrete_Random with - SPARK_Mode => Off + SPARK_Mode => On, + Always_Terminates is -- Basic facilities - type Generator is limited private; + type Generator is limited private with Default_Initial_Condition; - function Random (Gen : Generator) return Result_Subtype; + function Random (Gen : Generator) return Result_Subtype with + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); function Random (Gen : Generator; First : Result_Subtype; Last : Result_Subtype) return Result_Subtype - with Post => Random'Result in First .. Last; + with + Post => Random'Result in First .. Last, + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); - procedure Reset (Gen : Generator; Initiator : Integer); - procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + + procedure Reset (Gen : Generator) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); -- Advanced facilities type State is private; - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); + procedure Save (Gen : Generator; To_State : out State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + + procedure Reset (Gen : Generator; From_State : State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; + function Image (Of_State : State) return String with + Global => null; + function Value (Coded_State : String) return State with + Global => null; private + pragma SPARK_Mode (Off); + type Generator is new System.Random_Numbers.Generator; type State is new System.Random_Numbers.State; diff --git a/gcc/ada/libgnat/a-nuflra.ads b/gcc/ada/libgnat/a-nuflra.ads index 7eb0494..9ea73d4 100644 --- a/gcc/ada/libgnat/a-nuflra.ads +++ b/gcc/ada/libgnat/a-nuflra.ads @@ -39,34 +39,50 @@ with System.Random_Numbers; package Ada.Numerics.Float_Random with - SPARK_Mode => Off + SPARK_Mode => On, + Always_Terminates is -- Basic facilities - type Generator is limited private; + type Generator is limited private with Default_Initial_Condition; subtype Uniformly_Distributed is Float range 0.0 .. 1.0; - function Random (Gen : Generator) return Uniformly_Distributed; + function Random (Gen : Generator) return Uniformly_Distributed with + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + procedure Reset (Gen : Generator) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); - procedure Reset (Gen : Generator); - procedure Reset (Gen : Generator; Initiator : Integer); + procedure Reset (Gen : Generator; Initiator : Integer) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); -- Advanced facilities type State is private; - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); + procedure Save (Gen : Generator; To_State : out State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + procedure Reset (Gen : Generator; From_State : State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; + function Image (Of_State : State) return String with + Global => null; + function Value (Coded_State : String) return State with + Global => null; private + pragma SPARK_Mode (Off); + type Generator is new System.Random_Numbers.Generator; type State is new System.Random_Numbers.State; diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb index 5acfef4..50bb214 100644 --- a/gcc/ada/libgnat/a-strfix.adb +++ b/gcc/ada/libgnat/a-strfix.adb @@ -38,14 +38,6 @@ -- bounds of function return results were also fixed, and use of & removed for -- efficiency reasons. --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; package body Ada.Strings.Fixed with SPARK_Mode is @@ -153,12 +145,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : Character) return String is begin - return Result : String (1 .. Left) with Relaxed_Initialization do + return Result : String (1 .. Left) do for J in Result'Range loop Result (J) := Right; - pragma Loop_Invariant - (for all K in 1 .. J => - Result (K)'Initialized and then Result (K) = Right); end loop; end return; end "*"; @@ -168,82 +157,15 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : String) return String is Ptr : Integer := 0; - - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Integer) with - Ghost, - Pre => - Right'Length /= 0 - and then Ptr mod Right'Length = 0 - and then Ptr in 0 .. Natural'Last - Right'Length - and then K in Ptr .. Ptr + Right'Length - 1, - Post => K mod Right'Length = K - Ptr; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Right'Length. - - procedure Lemma_Split (Result : String) with - Ghost, - Relaxed_Initialization => Result, - Pre => - Right'Length /= 0 - and then Result'First = 1 - and then Result'Last >= 0 - and then Ptr mod Right'Length = 0 - and then Ptr in 0 .. Result'Last - Right'Length - and then Result (Result'First .. Ptr + Right'Length)'Initialized - and then Result (Ptr + 1 .. Ptr + Right'Length) = Right, - Post => - (for all K in Ptr + 1 .. Ptr + Right'Length => - Result (K) = Right (Right'First + (K - 1) mod Right'Length)); - -- Lemma_Split is used after Result (Ptr + 1 .. Ptr + Right'Length) is - -- updated to Right and concludes that the characters match for each - -- index when taken modulo Right'Length, as the considered slice starts - -- at index 1 modulo Right'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Integer) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split (Result : String) - is - begin - for K in Ptr + 1 .. Ptr + Right'Length loop - Lemma_Mod (K - 1); - pragma Loop_Invariant - (for all J in Ptr + 1 .. K => - Result (J) = Right (Right'First + (J - 1) mod Right'Length)); - end loop; - end Lemma_Split; - - -- Start of processing for "*" - begin if Right'Length = 0 then return ""; end if; - return Result : String (1 .. Left * Right'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Left * Right'Length) do for J in 1 .. Left loop Result (Ptr + 1 .. Ptr + Right'Length) := Right; - Lemma_Split (Result); Ptr := Ptr + Right'Length; - pragma Loop_Invariant (Ptr = J * Right'Length); - pragma Loop_Invariant (Result (1 .. Ptr)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Ptr => - Result (K) = Right (Right'First + (K - 1) mod Right'Length)); end loop; end return; end "*"; @@ -255,8 +177,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is function Delete (Source : String; From : Positive; - Through : Natural) return String - is + Through : Natural) return String is begin if From > Through then declare @@ -279,9 +200,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is Result_Length : constant Integer := Front_Len + Back_Len; -- Length of result begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization - do + return Result : String (1 .. Result_Length) do Result (1 .. Front_Len) := Source (Source'First .. From - 1); @@ -325,14 +244,11 @@ package body Ada.Strings.Fixed with SPARK_Mode is Result_Type (Source (Source'First .. Source'First + (Count - 1))); else - return Result : Result_Type with Relaxed_Initialization do + return Result : Result_Type do Result (1 .. Source'Length) := Source; for J in Source'Length + 1 .. Count loop Result (J) := Pad; - pragma Loop_Invariant - (for all K in Source'Length + 1 .. J => - Result (K)'Initialized and then Result (K) = Pad); end loop; end return; end if; @@ -342,8 +258,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Count : Natural; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Head (Source, Count, Pad), Target => Source, @@ -362,37 +277,21 @@ package body Ada.Strings.Fixed with SPARK_Mode is New_Item : String) return String is Front : constant Integer := Before - Source'First; - begin if Before - 1 not in Source'First - 1 .. Source'Last then raise Index_Error; end if; - return Result : String (1 .. Source'Length + New_Item'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length + New_Item'Length) do Result (1 .. Front) := Source (Source'First .. Before - 1); Result (Front + 1 .. Front + New_Item'Length) := New_Item; - pragma Assert - (Result (1 .. Before - Source'First) - = Source (Source'First .. Before - 1)); - pragma Assert - (Result - (Before - Source'First + 1 - .. Before - Source'First + New_Item'Length) - = New_Item); - if Before <= Source'Last then Result (Front + New_Item'Length + 1 .. Result'Last) := Source (Before .. Source'Last); end if; - - pragma Assert - (Result (1 .. Before - Source'First) - = Source (Source'First .. Before - 1)); end return; end Insert; @@ -400,8 +299,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Before : Positive; New_Item : String; - Drop : Truncation := Error) - is + Drop : Truncation := Error) is begin Move (Source => Insert (Source, Before, New_Item), Target => Source, @@ -536,38 +434,14 @@ package body Ada.Strings.Fixed with SPARK_Mode is Front : constant Integer := Position - Source'First; begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization - do + return Result : String (1 .. Result_Length) do Result (1 .. Front) := Source (Source'First .. Position - 1); - pragma Assert - (Result (1 .. Position - Source'First) - = Source (Source'First .. Position - 1)); Result (Front + 1 .. Front + New_Item'Length) := New_Item; - pragma Assert - (Result - (Position - Source'First + 1 - .. Position - Source'First + New_Item'Length) - = New_Item); if Position <= Source'Last - New_Item'Length then Result (Front + New_Item'Length + 1 .. Result'Last) := Source (Position + New_Item'Length .. Source'Last); - - pragma Assert - (Result - (Position - Source'First + New_Item'Length + 1 - .. Result'Last) - = Source (Position + New_Item'Length .. Source'Last)); end if; - - pragma Assert - (if Position <= Source'Last - New_Item'Length - then - Result - (Position - Source'First + New_Item'Length + 1 - .. Result'Last) - = Source (Position + New_Item'Length .. Source'Last)); end return; end; end Overwrite; @@ -576,8 +450,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Position : Positive; New_Item : String; - Drop : Truncation := Right) - is + Drop : Truncation := Right) is begin Move (Source => Overwrite (Source, Position, New_Item), Target => Source, @@ -612,39 +485,14 @@ package body Ada.Strings.Fixed with SPARK_Mode is -- Length of result begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization do + return Result : String (1 .. Result_Length) do Result (1 .. Front_Len) := Source (Source'First .. Low - 1); - pragma Assert - (Result (1 .. Integer'Max (0, Low - Source'First)) - = Source (Source'First .. Low - 1)); Result (Front_Len + 1 .. Front_Len + By'Length) := By; - pragma Assert - (Result - (Integer'Max (0, Low - Source'First) + 1 - .. Integer'Max (0, Low - Source'First) + By'Length) - = By); if High < Source'Last then Result (Front_Len + By'Length + 1 .. Result'Last) := Source (High + 1 .. Source'Last); end if; - - pragma Assert - (Result (1 .. Integer'Max (0, Low - Source'First)) - = Source (Source'First .. Low - 1)); - pragma Assert - (Result - (Integer'Max (0, Low - Source'First) + 1 - .. Integer'Max (0, Low - Source'First) + By'Length) - = By); - pragma Assert - (if High < Source'Last - then - Result - (Integer'Max (0, Low - Source'First) + By'Length + 1 - .. Result'Last) - = Source (High + 1 .. Source'Last)); end return; end; else @@ -659,8 +507,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is By : String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); end Replace_Slice; @@ -675,7 +522,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is Pad : Character := Space) return String is subtype Result_Type is String (1 .. Count); - begin if Count = 0 then return ""; @@ -686,12 +532,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is -- Pad on left else - return Result : Result_Type with Relaxed_Initialization do + return Result : Result_Type do for J in 1 .. Count - Source'Length loop Result (J) := Pad; - pragma Loop_Invariant - (for all K in 1 .. J => - Result (K)'Initialized and then Result (K) = Pad); end loop; if Source'Length /= 0 then @@ -705,8 +548,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Count : Natural; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Tail (Source, Count, Pad), Target => Source, @@ -721,35 +563,21 @@ package body Ada.Strings.Fixed with SPARK_Mode is function Translate (Source : String; - Mapping : Maps.Character_Mapping) return String - is + Mapping : Maps.Character_Mapping) return String is begin - return Result : String (1 .. Source'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length) do for J in Source'Range loop Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1))'Initialized); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1)) = - Value (Mapping, Source (K))); end loop; end return; end Translate; procedure Translate (Source : in out String; - Mapping : Maps.Character_Mapping) - is + Mapping : Maps.Character_Mapping) is begin for J in Source'Range loop Source (J) := Value (Mapping, Source (J)); - pragma Loop_Invariant - (for all K in Source'First .. J => - Source (K) = Value (Mapping, Source'Loop_Entry (K))); end loop; end Translate; @@ -759,23 +587,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is is pragma Unsuppress (Access_Check); begin - return Result : String (1 .. Source'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length) do for J in Source'Range loop Result (J - (Source'First - 1)) := Mapping.all (Source (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1))'Initialized); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1)) = Mapping (Source (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end return; end Translate; @@ -788,15 +602,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is begin for J in Source'Range loop Source (J) := Mapping.all (Source (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in Source'First .. J => - Source (K) = Mapping (Source'Loop_Entry (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end Translate; @@ -872,8 +677,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Side : Trim_End; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Trim (Source, Side), Source, @@ -887,7 +691,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : Maps.Character_Set) return String is High, Low : Integer; - begin Low := Index (Source, Set => Left, Test => Outside, Going => Forward); @@ -908,7 +711,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is declare Result_Length : constant Integer := High - Low + 1; subtype Result_Type is String (1 .. Result_Length); - begin return Result_Type (Source (Low .. High)); end; @@ -919,8 +721,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is Left : Maps.Character_Set; Right : Maps.Character_Set; Justify : Alignment := Strings.Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Trim (Source, Left, Right), Target => Source, diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb index 7490780..2f4cceb 100644 --- a/gcc/ada/libgnat/a-strmap.adb +++ b/gcc/ada/libgnat/a-strmap.adb @@ -35,14 +35,6 @@ -- is bit-by-bit or character-by-character and therefore rather slow. -- Generally for character sets we favor the full 32-byte representation. --- Assertions, ghost code and loop invariants in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Assert => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore); - package body Ada.Strings.Maps with SPARK_Mode is @@ -131,36 +123,15 @@ is --------------- function To_Domain (Map : Character_Mapping) return Character_Sequence is - Result : String (1 .. Map'Length) with Relaxed_Initialization; + Result : String (1 .. Map'Length); J : Natural; - - type Character_Index is array (Character) of Natural with Ghost; - Indexes : Character_Index := [others => 0] with Ghost; - begin J := 0; for C in Map'Range loop if Map (C) /= C then J := J + 1; Result (J) := C; - Indexes (C) := J; end if; - - pragma Loop_Invariant (if Map = Identity then J = 0); - pragma Loop_Invariant (J <= Character'Pos (C) + 1); - pragma Loop_Invariant (for all K in 1 .. J => Result (K)'Initialized); - pragma Loop_Invariant (for all K in 1 .. J => Result (K) <= C); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. J))); - pragma Loop_Invariant - (for all D in Map'First .. C => - (if Map (D) = D then - Indexes (D) = 0 - else - Indexes (D) in 1 .. J - and then Result (Indexes (D)) = D)); - pragma Loop_Invariant - (for all Char of Result (1 .. J) => Map (Char) /= Char); end loop; return Result (1 .. J); @@ -173,7 +144,7 @@ is function To_Mapping (From, To : Character_Sequence) return Character_Mapping is - Result : Character_Mapping with Relaxed_Initialization; + Result : Character_Mapping; Inserted : Character_Set := Null_Set; From_Len : constant Natural := From'Length; To_Len : constant Natural := To'Length; @@ -185,9 +156,6 @@ is for Char in Character loop Result (Char) := Char; - pragma Loop_Invariant (Result (Result'First .. Char)'Initialized); - pragma Loop_Invariant - (for all C in Result'First .. Char => Result (C) = C); end loop; for J in From'Range loop @@ -197,23 +165,6 @@ is Result (From (J)) := To (J - From'First + To'First); Inserted (From (J)) := True; - - pragma Loop_Invariant (Result'Initialized); - pragma Loop_Invariant - (for all K in From'First .. J => - Result (From (K)) = To (K - From'First + To'First) - and then Inserted (From (K))); - pragma Loop_Invariant - (for all Char in Character => - (Inserted (Char) = - (for some K in From'First .. J => Char = From (K)))); - pragma Loop_Invariant - (for all Char in Character => - (if not Inserted (Char) then Result (Char) = Char)); - pragma Loop_Invariant - (if (for all K in From'First .. J => - From (K) = To (J - From'First + To'First)) - then Result = Identity); end loop; return Result; @@ -224,195 +175,16 @@ is -------------- function To_Range (Map : Character_Mapping) return Character_Sequence is - - -- Extract from the postcondition of To_Domain the essential properties - -- that define Seq as the domain of Map. - function Is_Domain - (Map : Character_Mapping; - Seq : Character_Sequence) - return Boolean - is - (Seq'First = 1 - and then - SPARK_Proof_Sorted_Character_Sequence (Seq) - and then - (for all Char in Character => - (if (for all X of Seq => X /= Char) - then Map (Char) = Char)) - and then - (for all Char of Seq => Map (Char) /= Char)) - with - Ghost; - - -- Given Map, there is a unique sequence Seq for which - -- Is_Domain(Map,Seq) holds. - procedure Lemma_Domain_Unicity - (Map : Character_Mapping; - Seq1, Seq2 : Character_Sequence) - with - Ghost, - Pre => Is_Domain (Map, Seq1) - and then Is_Domain (Map, Seq2), - Post => Seq1 = Seq2; - - -- Isolate the proof that To_Domain(Map) returns a sequence for which - -- Is_Domain holds. - procedure Lemma_Is_Domain (Map : Character_Mapping) - with - Ghost, - Post => Is_Domain (Map, To_Domain (Map)); - - -- Deduce the alternative expression of sortedness from the one in - -- SPARK_Proof_Sorted_Character_Sequence which compares consecutive - -- elements. - procedure Lemma_Is_Sorted (Seq : Character_Sequence) - with - Ghost, - Pre => SPARK_Proof_Sorted_Character_Sequence (Seq), - Post => (for all J in Seq'Range => - (for all K in Seq'Range => - (if J < K then Seq (J) < Seq (K)))); - - -------------------------- - -- Lemma_Domain_Unicity -- - -------------------------- - - procedure Lemma_Domain_Unicity - (Map : Character_Mapping; - Seq1, Seq2 : Character_Sequence) - is - J : Positive := 1; - - begin - while J <= Seq1'Last - and then J <= Seq2'Last - and then Seq1 (J) = Seq2 (J) - loop - pragma Loop_Invariant - (Seq1 (Seq1'First .. J) = Seq2 (Seq2'First .. J)); - pragma Loop_Variant (Increases => J); - - if J = Positive'Last then - return; - end if; - - J := J + 1; - end loop; - - Lemma_Is_Sorted (Seq1); - Lemma_Is_Sorted (Seq2); - - if J <= Seq1'Last - and then J <= Seq2'Last - then - if Seq1 (J) < Seq2 (J) then - pragma Assert (for all X of Seq2 => X /= Seq1 (J)); - pragma Assert (Map (Seq1 (J)) = Seq1 (J)); - pragma Assert (False); - else - pragma Assert (for all X of Seq1 => X /= Seq2 (J)); - pragma Assert (Map (Seq2 (J)) = Seq2 (J)); - pragma Assert (False); - end if; - - elsif J <= Seq1'Last then - pragma Assert (for all X of Seq2 => X /= Seq1 (J)); - pragma Assert (Map (Seq1 (J)) = Seq1 (J)); - pragma Assert (False); - - elsif J <= Seq2'Last then - pragma Assert (for all X of Seq1 => X /= Seq2 (J)); - pragma Assert (Map (Seq2 (J)) = Seq2 (J)); - pragma Assert (False); - end if; - end Lemma_Domain_Unicity; - - --------------------- - -- Lemma_Is_Domain -- - --------------------- - - procedure Lemma_Is_Domain (Map : Character_Mapping) is - Ignore : constant Character_Sequence := To_Domain (Map); - begin - null; - end Lemma_Is_Domain; - - --------------------- - -- Lemma_Is_Sorted -- - --------------------- - - procedure Lemma_Is_Sorted (Seq : Character_Sequence) is - begin - for A in Seq'Range loop - exit when A = Positive'Last; - - for B in A + 1 .. Seq'Last loop - pragma Loop_Invariant - (for all K in A + 1 .. B => Seq (A) < Seq (K)); - end loop; - - pragma Loop_Invariant - (for all J in Seq'First .. A => - (for all K in Seq'Range => - (if J < K then Seq (J) < Seq (K)))); - end loop; - end Lemma_Is_Sorted; - - -- Local variables - - Result : String (1 .. Map'Length) with Relaxed_Initialization; + Result : String (1 .. Map'Length); J : Natural; - - -- Repeat the computation from To_Domain in ghost code, in order to - -- prove the relationship between Result and To_Domain(Map). - - Domain : String (1 .. Map'Length) with Ghost, Relaxed_Initialization; - type Character_Index is array (Character) of Natural with Ghost; - Indexes : Character_Index := [others => 0] with Ghost; - - -- Start of processing for To_Range - begin J := 0; for C in Map'Range loop if Map (C) /= C then J := J + 1; Result (J) := Map (C); - Domain (J) := C; - Indexes (C) := J; end if; - - -- Repeat the loop invariants from To_Domain regarding Domain and - -- Indexes. Add similar loop invariants for Result and Indexes. - - pragma Loop_Invariant (J <= Character'Pos (C) + 1); - pragma Loop_Invariant (Result (1 .. J)'Initialized); - pragma Loop_Invariant (Domain (1 .. J)'Initialized); - pragma Loop_Invariant (for all K in 1 .. J => Domain (K) <= C); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Domain (1 .. J))); - pragma Loop_Invariant - (for all D in Map'First .. C => - (if Map (D) = D then - Indexes (D) = 0 - else - Indexes (D) in 1 .. J - and then Domain (Indexes (D)) = D - and then Result (Indexes (D)) = Map (D))); - pragma Loop_Invariant - (for all Char of Domain (1 .. J) => Map (Char) /= Char); - pragma Loop_Invariant - (for all K in 1 .. J => Result (K) = Map (Domain (K))); end loop; - pragma Assert (Is_Domain (Map, Domain (1 .. J))); - - -- Show the equality of Domain and To_Domain(Map) - - Lemma_Is_Domain (Map); - Lemma_Domain_Unicity (Map, Domain (1 .. J), To_Domain (Map)); - pragma Assert - (for all K in 1 .. J => Domain (K) = To_Domain (Map) (K)); - pragma Assert (To_Domain (Map)'Length = J); return Result (1 .. J); end To_Range; @@ -422,27 +194,18 @@ is --------------- function To_Ranges (Set : Character_Set) return Character_Ranges is - Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1) - with Relaxed_Initialization; + Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1); Range_Num : Natural; C : Character; - C_Iter : Character with Ghost; begin C := Character'First; Range_Num := 0; loop - C_Iter := C; - -- Skip gap between subsets while not Set (C) loop - pragma Loop_Invariant - (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); - pragma Loop_Invariant - (for all Char in C'Loop_Entry .. C => not Set (Char)); - pragma Loop_Variant (Increases => C); exit when C = Character'Last; C := Character'Succ (C); end loop; @@ -455,12 +218,6 @@ is -- Span a subset loop - pragma Loop_Invariant - (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); - pragma Loop_Invariant - (for all Char in C'Loop_Entry .. C => - (if Char /= C then Set (Char))); - pragma Loop_Variant (Increases => C); exit when not Set (C) or else C = Character'Last; C := Character'Succ (C); end loop; @@ -471,31 +228,6 @@ is else Max_Ranges (Range_Num).High := Character'Pred (C); end if; - - pragma Assert - (for all Char in C_Iter .. C => - (Set (Char) = - (Char in Max_Ranges (Range_Num).Low .. - Max_Ranges (Range_Num).High))); - pragma Assert - (for all Char in Character'First .. C_Iter => - (if Char /= C_Iter then - (Set (Char) = - (for some Span of Max_Ranges (1 .. Range_Num - 1) => - Char in Span.Low .. Span.High)))); - - pragma Loop_Invariant (2 * Range_Num <= Character'Pos (C) + 1); - pragma Loop_Invariant (Max_Ranges (1 .. Range_Num)'Initialized); - pragma Loop_Invariant (not Set (C)); - pragma Loop_Invariant - (for all Char in Character'First .. C => - (Set (Char) = - (for some Span of Max_Ranges (1 .. Range_Num) => - Char in Span.Low .. Span.High))); - pragma Loop_Invariant - (for all Span of Max_Ranges (1 .. Range_Num) => - (for all Char in Span.Low .. Span.High => Set (Char))); - pragma Loop_Variant (Increases => Range_Num); end loop; return Max_Ranges (1 .. Range_Num); @@ -506,8 +238,7 @@ is ----------------- function To_Sequence (Set : Character_Set) return Character_Sequence is - Result : String (1 .. Character'Pos (Character'Last) + 1) - with Relaxed_Initialization; + Result : String (1 .. Character'Pos (Character'Last) + 1); Count : Natural := 0; begin for Char in Set'Range loop @@ -515,17 +246,6 @@ is Count := Count + 1; Result (Count) := Char; end if; - - pragma Loop_Invariant (Count <= Character'Pos (Char) + 1); - pragma Loop_Invariant (Result (1 .. Count)'Initialized); - pragma Loop_Invariant (for all K in 1 .. Count => Result (K) <= Char); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. Count))); - pragma Loop_Invariant - (for all C in Set'First .. Char => - (Set (C) = (for some X of Result (1 .. Count) => C = X))); - pragma Loop_Invariant - (for all Char of Result (1 .. Count) => Is_In (Char, Set)); end loop; return Result (1 .. Count); @@ -541,19 +261,7 @@ is for R in Ranges'Range loop for C in Ranges (R).Low .. Ranges (R).High loop Result (C) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - ((for some Prev in Ranges'First .. R - 1 => - Char in Ranges (Prev).Low .. Ranges (Prev).High) - or else Char in Ranges (R).Low .. C)); end loop; - - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - (for some Prev in Ranges'First .. R => - Char in Ranges (Prev).Low .. Ranges (Prev).High)); end loop; return Result; @@ -564,9 +272,6 @@ is begin for C in Span.Low .. Span.High loop Result (C) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = (Char in Span.Low .. C)); end loop; return Result; @@ -577,10 +282,6 @@ is begin for J in Sequence'Range loop Result (Sequence (J)) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - (for some K in Sequence'First .. J => Char = Sequence (K))); end loop; return Result; @@ -599,8 +300,6 @@ is function Value (Map : Character_Mapping; - Element : Character) return Character - is - (Map (Element)); + Element : Character) return Character is (Map (Element)); end Ada.Strings.Maps; diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb index 45fb682..55bf767 100644 --- a/gcc/ada/libgnat/a-strsea.adb +++ b/gcc/ada/libgnat/a-strsea.adb @@ -35,14 +35,6 @@ -- case of identity mappings for Count and Index, and also Index_Non_Blank -- is specialized (rather than using the general Index routine). --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; with System; use System; @@ -110,10 +102,6 @@ package body Ada.Strings.Search with SPARK_Mode is Num := Num + 1; Ind := Ind + PL1; end if; - - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; -- Mapped case @@ -125,25 +113,15 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Value (Mapping, Source (Ind + (K - Pattern'First))) then - pragma Assert (not Match (Source, Pattern, Mapping, Ind)); goto Cont; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); Num := Num + 1; Ind := Ind + PL1; <<Cont>> null; - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; end if; @@ -185,30 +163,15 @@ package body Ada.Strings.Search with SPARK_Mode is Ind := Ind + 1; for K in Pattern'Range loop if Pattern (K) /= Mapping (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Assert (not Match (Source, Pattern, Mapping, Ind)); goto Cont; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); Num := Num + 1; Ind := Ind + PL1; <<Cont>> null; - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; return Num; @@ -219,10 +182,8 @@ package body Ada.Strings.Search with SPARK_Mode is Set : Maps.Character_Set) return Natural is N : Natural := 0; - begin for J in Source'Range loop - pragma Loop_Invariant (N <= J - Source'First); if Is_In (Source (J), Set) then N := N + 1; end if; @@ -241,8 +202,7 @@ package body Ada.Strings.Search with SPARK_Mode is From : Positive; Test : Membership; First : out Positive; - Last : out Natural) - is + Last : out Natural) is begin -- AI05-031: Raise Index error if Source non-empty and From not in range @@ -264,10 +224,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := K - 1; return; end if; - - pragma Loop_Invariant - (for all L in J .. K => - Belongs (Source (L), Set, Test)); end loop; end if; @@ -277,10 +233,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := Source'Last; return; end if; - - pragma Loop_Invariant - (for all K in Integer'Max (From, Source'First) .. J => - not Belongs (Source (K), Set, Test)); end loop; -- Here if no token found @@ -294,8 +246,7 @@ package body Ada.Strings.Search with SPARK_Mode is Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural) - is + Last : out Natural) is begin for J in Source'Range loop if Belongs (Source (J), Set, Test) then @@ -307,10 +258,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := K - 1; return; end if; - - pragma Loop_Invariant - (for all L in J .. K => - Belongs (Source (L), Set, Test)); end loop; end if; @@ -320,10 +267,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := Source'Last; return; end if; - - pragma Loop_Invariant - (for all K in Source'First .. J => - not Belongs (Source (K), Set, Test)); end loop; -- Here if no token found @@ -335,7 +278,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source'First not in Positive then raise Constraint_Error; - else First := Source'First; Last := 0; @@ -353,7 +295,6 @@ package body Ada.Strings.Search with SPARK_Mode is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is PL1 : constant Integer := Pattern'Length - 1; - begin if Pattern = "" then raise Pattern_Error; @@ -374,13 +315,8 @@ package body Ada.Strings.Search with SPARK_Mode is if Is_Identity (Mapping) then for Ind in Source'First .. Source'Last - PL1 loop if Pattern = Source (Ind .. Ind + PL1) then - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; end if; - - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); end loop; -- Mapped forward case @@ -393,20 +329,11 @@ package body Ada.Strings.Search with SPARK_Mode is then goto Cont1; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont1>> - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -419,13 +346,8 @@ package body Ada.Strings.Search with SPARK_Mode is if Is_Identity (Mapping) then for Ind in reverse Source'First .. Source'Last - PL1 loop if Pattern = Source (Ind .. Ind + PL1) then - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; end if; - - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); end loop; -- Mapped backward case @@ -438,20 +360,11 @@ package body Ada.Strings.Search with SPARK_Mode is then goto Cont2; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont2>> - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -495,27 +408,17 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Mapping.all (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); goto Cont1; end if; pragma Loop_Invariant (for all J in Pattern'First .. K => Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont1>> - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); null; end loop; @@ -527,26 +430,13 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Mapping.all (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); goto Cont2; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; return Ind; <<Cont2>> - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -561,8 +451,7 @@ package body Ada.Strings.Search with SPARK_Mode is (Source : String; Set : Maps.Character_Set; Test : Membership := Inside; - Going : Direction := Forward) return Natural - is + Going : Direction := Forward) return Natural is begin -- Forwards case @@ -571,10 +460,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Belongs (Source (J), Set, Test) then return J; end if; - - pragma Loop_Invariant - (for all C of Source (Source'First .. J) => - not Belongs (C, Set, Test)); end loop; -- Backwards case @@ -584,10 +469,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Belongs (Source (J), Set, Test) then return J; end if; - - pragma Loop_Invariant - (for all C of Source (J .. Source'Last) => - not Belongs (C, Set, Test)); end loop; end if; @@ -604,7 +485,6 @@ package body Ada.Strings.Search with SPARK_Mode is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is Result : Natural; - PL1 : constant Integer := Pattern'Length - 1; begin -- AI05-056: If source is empty result is always zero @@ -619,12 +499,6 @@ package body Ada.Strings.Search with SPARK_Mode is Result := Index (Source (From .. Source'Last), Pattern, Forward, Mapping); - pragma Assert - (if (for some J in From .. Source'Last - PL1 => - Match (Source, Pattern, Mapping, J)) - then Result in From .. Source'Last - PL1 - and then Match (Source, Pattern, Mapping, Result) - else Result = 0); else if From > Source'Last then @@ -633,12 +507,6 @@ package body Ada.Strings.Search with SPARK_Mode is Result := Index (Source (Source'First .. From), Pattern, Backward, Mapping); - pragma Assert - (if (for some J in Source'First .. From - PL1 => - Match (Source, Pattern, Mapping, J)) - then Result in Source'First .. From - PL1 - and then Match (Source, Pattern, Mapping, Result) - else Result = 0); end if; return Result; @@ -722,9 +590,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source (J) /= ' ' then return J; end if; - - pragma Loop_Invariant - (for all C of Source (Source'First .. J) => C = ' '); end loop; else -- Going = Backward @@ -732,9 +597,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source (J) /= ' ' then return J; end if; - - pragma Loop_Invariant - (for all C of Source (J .. Source'Last) => C = ' '); end loop; end if; diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb index 6540924..8afde71 100644 --- a/gcc/ada/libgnat/a-strsup.adb +++ b/gcc/ada/libgnat/a-strsup.adb @@ -29,15 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop (in)variants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Loop_Variant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; package body Ada.Strings.Superbounded with SPARK_Mode is @@ -1438,91 +1429,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Indx : Natural; Ilen : constant Natural := Item'Length; - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Natural; Q : Natural) with - Ghost, - Pre => Ilen /= 0 - and then Q mod Ilen = 0 - and then K - Q in 0 .. Ilen - 1, - Post => K mod Ilen = K - Q; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Item'Length. - - procedure Lemma_Mod_Zero (X : Natural) with - Ghost, - Pre => Ilen /= 0 - and then X mod Ilen = 0 - and then X <= Natural'Last - Ilen, - Post => (X + Ilen) mod Ilen = 0; - -- Lemma_Mod_Zero is applied to prove that the length of the range - -- of indexes considered in the loop, when dropping on the Left, is - -- a multiple of Item'Length. - - procedure Lemma_Split (Going : Direction) with - Ghost, - Pre => - Ilen /= 0 - and then Indx in 0 .. Max_Length - Ilen - and then - (if Going = Forward - then Indx mod Ilen = 0 - else (Max_Length - Indx - Ilen) mod Ilen = 0) - and then Result.Data (Indx + 1 .. Indx + Ilen)'Initialized - and then String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item, - Post => - (if Going = Forward then - (for all J in Indx + 1 .. Indx + Ilen => - Result.Data (J) = Item (Item'First + (J - 1) mod Ilen)) - else - (for all J in Indx + 1 .. Indx + Ilen => - Result.Data (J) = - Item (Item'Last - (Max_Length - J) mod Ilen))); - -- Lemma_Split is used after Result.Data (Indx + 1 .. Indx + Ilen) is - -- updated to Item and concludes that the characters match for each - -- index when taken modulo Item'Length, as the considered slice starts - -- at index 1 (or ends at index Max_Length, if Going = Backward) modulo - -- Item'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Natural; Q : Natural) is null; - - -------------------- - -- Lemma_Mod_Zero -- - -------------------- - - procedure Lemma_Mod_Zero (X : Natural) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split (Going : Direction) is - begin - if Going = Forward then - for K in Indx + 1 .. Indx + Ilen loop - Lemma_Mod (K - 1, Indx); - pragma Loop_Invariant - (for all J in Indx + 1 .. K => - Result.Data (J) = Item (Item'First + (J - 1) mod Ilen)); - end loop; - else - for K in Indx + 1 .. Indx + Ilen loop - Lemma_Mod (Max_Length - K, Max_Length - Indx - Ilen); - pragma Loop_Invariant - (for all J in Indx + 1 .. K => - Result.Data (J) = - Item (Item'Last - (Max_Length - J) mod Ilen)); - end loop; - end if; - end Lemma_Split; - begin if Count = 0 or else Ilen <= Max_Length / Count then if Count * Ilen > 0 then @@ -1531,19 +1437,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is for J in 1 .. Count loop Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Forward); Indx := Indx + Ilen; - pragma Loop_Invariant (Indx = J * Ilen); - pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Indx => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); end loop; end if; @@ -1557,36 +1451,11 @@ package body Ada.Strings.Superbounded with SPARK_Mode is while Indx < Max_Length - Ilen loop Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Forward); Indx := Indx + Ilen; - pragma Loop_Invariant (Indx mod Ilen = 0); - pragma Loop_Invariant (Indx in 0 .. Max_Length - 1); - pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Indx => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); - pragma Loop_Variant (Increases => Indx); end loop; Result.Data (Indx + 1 .. Max_Length) := Super_String_Data (Item (Item'First .. Item'First + (Max_Length - Indx - 1))); - pragma Assert - (for all J in Indx + 1 .. Max_Length => - Result.Data (J) = Item (Item'First - 1 - Indx + J)); - - for J in Indx + 1 .. Max_Length loop - Lemma_Mod (J - 1, Indx); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); - end loop; when Strings.Left => Indx := Max_Length; @@ -1595,40 +1464,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Indx := Indx - Ilen; Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Backward); - Lemma_Mod_Zero (Max_Length - Indx - Ilen); - pragma Loop_Invariant - ((Max_Length - Indx) mod Ilen = 0); - pragma Loop_Invariant (Indx in 1 .. Max_Length); - pragma Loop_Invariant - (Result.Data (Indx + 1 .. Max_Length)'Initialized); - pragma Loop_Invariant - (for all K in Indx + 1 .. Max_Length => - Result.Data (K) = - Item (Item'Last - (Max_Length - K) mod Ilen)); - pragma Loop_Variant (Decreases => Indx); end loop; Result.Data (1 .. Indx) := Super_String_Data (Item (Item'Last - Indx + 1 .. Item'Last)); - pragma Assert - (for all J in 1 .. Indx => - Result.Data (J) = Item (Item'Last - Indx + J)); - - for J in reverse 1 .. Indx loop - Lemma_Mod (Max_Length - J, Max_Length - Indx); - pragma Loop_Invariant - (for all K in J .. Max_Length => - Result.Data (K) = - Item (Item'Last - (Max_Length - K) mod Ilen)); - end loop; - pragma Assert - (Result.Data (1 .. Max_Length)'Initialized); when Strings.Error => raise Ada.Strings.Length_Error; @@ -1643,8 +1482,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is function Super_Replicate (Count : Natural; Item : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is + Drop : Strings.Truncation := Strings.Error) return Super_String is begin return Super_Replicate (Count, Super_To_String (Item), Drop, Item.Max_Length); @@ -1820,14 +1658,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Mapping : Maps.Character_Mapping) return Super_String is Result : Super_String (Source.Max_Length); - begin for J in 1 .. Source.Current_Length loop Result.Data (J) := Value (Mapping, Source.Data (J)); - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = Value (Mapping, Source.Data (K))); end loop; Result.Current_Length := Source.Current_Length; @@ -1836,14 +1669,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is procedure Super_Translate (Source : in out Super_String; - Mapping : Maps.Character_Mapping) - is + Mapping : Maps.Character_Mapping) is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Value (Mapping, Source.Data (J)); - pragma Loop_Invariant - (for all K in 1 .. J => - Source.Data (K) = Value (Mapping, Source'Loop_Entry.Data (K))); end loop; end Super_Translate; @@ -1852,20 +1681,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Mapping : Maps.Character_Mapping_Function) return Super_String is Result : Super_String (Source.Max_Length); - begin for J in 1 .. Source.Current_Length loop Result.Data (J) := Mapping.all (Source.Data (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = Mapping (Source.Data (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; Result.Current_Length := Source.Current_Length; @@ -1874,20 +1692,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is procedure Super_Translate (Source : in out Super_String; - Mapping : Maps.Character_Mapping_Function) - is + Mapping : Maps.Character_Mapping_Function) is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Mapping.all (Source.Data (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in 1 .. J => - Source.Data (K) = Mapping (Source'Loop_Entry.Data (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end Super_Translate; @@ -1901,7 +1709,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is is Result : Super_String (Source.Max_Length); Last : constant Natural := Source.Current_Length; - begin case Side is when Strings.Left => @@ -2101,13 +1908,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is begin if Left > Max_Length then raise Ada.Strings.Length_Error; - else for J in 1 .. Left loop Result.Data (J) := Right; - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => Result.Data (K) = Right); end loop; Result.Current_Length := Left; @@ -2126,80 +1929,15 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Rlen : constant Natural := Right'Length; Nlen : constant Natural := Left * Rlen; - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Integer) with - Ghost, - Pre => - Rlen /= 0 - and then Pos mod Rlen = 0 - and then Pos in 0 .. Max_Length - Rlen - and then K in Pos .. Pos + Rlen - 1, - Post => K mod Rlen = K - Pos; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Right'Length. - - procedure Lemma_Split with - Ghost, - Pre => - Rlen /= 0 - and then Pos mod Rlen = 0 - and then Pos in 0 .. Max_Length - Rlen - and then Result.Data (1 .. Pos + Rlen)'Initialized - and then String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right, - Post => - (for all K in Pos + 1 .. Pos + Rlen => - Result.Data (K) = Right (Right'First + (K - 1) mod Rlen)); - -- Lemma_Split is used after Result.Data (Pos + 1 .. Pos + Rlen) is - -- updated to Right and concludes that the characters match for each - -- index when taken modulo Right'Length, as the considered slice starts - -- at index 1 modulo Right'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Integer) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split is - begin - for K in Pos + 1 .. Pos + Rlen loop - Lemma_Mod (K - 1); - pragma Loop_Invariant - (for all J in Pos + 1 .. K => - Result.Data (J) = Right (Right'First + (J - 1) mod Rlen)); - end loop; - end Lemma_Split; - begin if Nlen > Max_Length then raise Ada.Strings.Length_Error; - else if Nlen > 0 then for J in 1 .. Left loop Result.Data (Pos + 1 .. Pos + Rlen) := Super_String_Data (Right); - pragma Assert - (for all K in 1 .. Rlen => Result.Data (Pos + K) = - Right (Right'First - 1 + K)); - pragma Assert - (String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right); - Lemma_Split; Pos := Pos + Rlen; - pragma Loop_Invariant (Pos = J * Rlen); - pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Pos => - Result.Data (K) = - Right (Right'First + (K - 1) mod Rlen)); end loop; end if; @@ -2221,19 +1959,12 @@ package body Ada.Strings.Superbounded with SPARK_Mode is begin if Nlen > Right.Max_Length then raise Ada.Strings.Length_Error; - else if Nlen > 0 then for J in 1 .. Left loop Result.Data (Pos + 1 .. Pos + Rlen) := Right.Data (1 .. Rlen); Pos := Pos + Rlen; - pragma Loop_Invariant (Pos = J * Rlen); - pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Pos => - Result.Data (K) = - Right.Data (1 + (K - 1) mod Rlen)); end loop; end if; @@ -2259,7 +1990,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is if Slen <= Max_Length then Result.Data (1 .. Slen) := Super_String_Data (Source); Result.Current_Length := Slen; - else case Drop is when Strings.Right => diff --git a/gcc/ada/libgnat/g-dyntab.ads b/gcc/ada/libgnat/g-dyntab.ads index 7e2e3b2..7810986 100644 --- a/gcc/ada/libgnat/g-dyntab.ads +++ b/gcc/ada/libgnat/g-dyntab.ads @@ -168,8 +168,9 @@ package GNAT.Dynamic_Tables is -- -- Tab : Table_Type renames X.Table (First .. X.Last); -- - -- Note: The Table component must come first. See declarations of - -- SCO_Unit_Table and SCO_Table in scos.h. + -- Note: The Table component must come first to simplify interfacing + -- with C, similar to how we do it for the Table unit; see declarations + -- of Names_Ptr and Names_Char_Ptr in namet.h. Locked : Boolean := False; -- Table reallocation is permitted only if this is False. A client may diff --git a/gcc/ada/libgnat/i-c.adb b/gcc/ada/libgnat/i-c.adb index d248ceb..e63c014 100644 --- a/gcc/ada/libgnat/i-c.adb +++ b/gcc/ada/libgnat/i-c.adb @@ -29,78 +29,10 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body Interfaces.C with SPARK_Mode is - -------------------- - -- C_Length_Ghost -- - -------------------- - - function C_Length_Ghost (Item : char_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : wchar_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = wide_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= wide_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : char16_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = char16_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char16_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : char32_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = char32_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char32_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - ----------------------- -- Is_Nul_Terminated -- ----------------------- @@ -113,9 +45,6 @@ is if Item (J) = nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= nul); end loop; return False; @@ -129,9 +58,6 @@ is if Item (J) = wide_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= wide_nul); end loop; return False; @@ -145,9 +71,6 @@ is if Item (J) = char16_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char16_nul); end loop; return False; @@ -161,9 +84,6 @@ is if Item (J) = char32_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char32_nul); end loop; return False; @@ -194,14 +114,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = nul then @@ -211,8 +123,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -220,17 +130,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : String (1 .. Count_Cst) with Relaxed_Initialization; - + R : String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -252,14 +155,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = nul then @@ -285,19 +180,6 @@ is for J in 1 .. Count loop Target (To) := Character (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -329,14 +211,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = wide_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= wide_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = wide_nul then @@ -346,8 +220,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -355,17 +227,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization; - + R : Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -387,14 +252,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = wide_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= wide_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = wide_nul then @@ -420,19 +277,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -464,14 +308,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char16_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char16_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char16_nul then @@ -481,8 +317,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -490,17 +324,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization; - + R : Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -522,14 +349,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char16_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char16_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char16_nul then @@ -555,19 +374,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -599,15 +405,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char32_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char32_nul); - pragma Loop_Invariant (From <= Item'First + C_Length_Ghost (Item)); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char32_nul then @@ -617,8 +414,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -626,17 +421,11 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_Wide_String (1 .. Count_Cst) with Relaxed_Initialization; + R : Wide_Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -658,14 +447,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char32_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char32_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char32_nul then @@ -691,19 +472,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -734,26 +502,14 @@ is begin if Append_Nul then declare - R : char_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -774,19 +530,10 @@ is else declare - R : char_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -814,18 +561,6 @@ is for From in Item'Range loop Target (To) := char (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; @@ -836,7 +571,6 @@ is Target (To) := nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -859,26 +593,14 @@ is begin if Append_Nul then declare - R : wchar_array (0 .. Item'Length) with Relaxed_Initialization; - + R : wchar_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := wide_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -895,19 +617,10 @@ is else declare - R : wchar_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : wchar_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -925,40 +638,17 @@ is Append_Nul : Boolean := True) is To : size_t; - begin if Target'Length < Item'Length then raise Constraint_Error; - else To := Target'First; for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then if To > Target'Last then raise Constraint_Error; @@ -966,7 +656,6 @@ is Target (To) := wide_nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -989,26 +678,14 @@ is begin if Append_Nul then declare - R : char16_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char16_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := char16_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -1022,22 +699,12 @@ is if Item'Length = 0 then raise Constraint_Error; - else declare - R : char16_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char16_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -1055,7 +722,6 @@ is Append_Nul : Boolean := True) is To : size_t; - begin if Target'Length < Item'Length then raise Constraint_Error; @@ -1065,30 +731,9 @@ is for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then if To > Target'Last then raise Constraint_Error; @@ -1096,7 +741,6 @@ is Target (To) := char16_nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -1119,26 +763,14 @@ is begin if Append_Nul then declare - R : char32_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char32_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := char32_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -1154,19 +786,10 @@ is else declare - R : char32_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char32_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -1188,36 +811,15 @@ is begin if Target'Length < Item'Length + (if Append_Nul then 1 else 0) then raise Constraint_Error; - else To := Target'First; + for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then Target (To) := char32_nul; Count := Item'Length + 1; @@ -1226,7 +828,5 @@ is end if; end if; end To_C; - pragma Annotate (CodePeer, False_Positive, "validity check", - "Count is only uninitialized on abnormal return."); end Interfaces.C; diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads index f9f9f75..fc77caf 100644 --- a/gcc/ada/libgnat/i-c.ads +++ b/gcc/ada/libgnat/i-c.ads @@ -133,6 +133,7 @@ is function C_Length_Ghost (Item : char_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = nul @@ -274,6 +275,7 @@ is function C_Length_Ghost (Item : wchar_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = wide_nul @@ -395,6 +397,7 @@ is function C_Length_Ghost (Item : char16_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = char16_nul @@ -510,6 +513,7 @@ is function C_Length_Ghost (Item : char32_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = char32_nul diff --git a/gcc/ada/libgnat/i-cstrin.adb b/gcc/ada/libgnat/i-cstrin.adb index 7bf881f..8279562 100644 --- a/gcc/ada/libgnat/i-cstrin.adb +++ b/gcc/ada/libgnat/i-cstrin.adb @@ -66,8 +66,11 @@ is pragma Inline ("+"); -- Address arithmetic on chars_ptr value - function Position_Of_Nul (Into : char_array) return size_t; - -- Returns position of the first Nul in Into or Into'Last + 1 if none + procedure Position_Of_Nul + (Into : char_array; Found : out Boolean; Index : out size_t); + -- If into contains a Nul character, Found is set to True and Index + -- contains the position of the first Nul character in Into. Otherwise + -- Found is set to False and the value of Index is not meaningful. -- We can't use directly System.Memory because the categorization is not -- compatible, so we directly import here the malloc and free routines. @@ -107,6 +110,7 @@ is -------------------- function New_Char_Array (Chars : char_array) return chars_ptr is + Found : Boolean; Index : size_t; Pointer : chars_ptr; @@ -114,24 +118,25 @@ is -- Get index of position of null. If Index > Chars'Last, -- nul is absent and must be added explicitly. - Index := Position_Of_Nul (Into => Chars); - Pointer := Memory_Alloc ((Index - Chars'First + 1)); + Position_Of_Nul (Into => Chars, Found => Found, Index => Index); -- If nul is present, transfer string up to and including nul - if Index <= Chars'Last then - Update (Item => Pointer, - Offset => 0, - Chars => Chars (Chars'First .. Index), - Check => False); + if Found then + Pointer := Memory_Alloc (Index - Chars'First + 1); + + Update + (Item => Pointer, + Offset => 0, + Chars => Chars (Chars'First .. Index), + Check => False); else -- If original string has no nul, transfer whole string and add -- terminator explicitly. - Update (Item => Pointer, - Offset => 0, - Chars => Chars, - Check => False); + Pointer := Memory_Alloc (Chars'Length + 1); + + Update (Item => Pointer, Offset => 0, Chars => Chars, Check => False); Poke (nul, Into => Pointer + size_t'(Chars'Length)); end if; @@ -148,20 +153,33 @@ is -- the result, and doesn't copy the string on the stack, otherwise its -- use is limited when used from tasks on large strings. - Result : constant chars_ptr := Memory_Alloc (Str'Length + 1); + Len : Natural := 0; + -- Length of the longest prefix of Str that doesn't contain NUL - Result_Array : char_array (1 .. Str'Length + 1); - for Result_Array'Address use To_Address (Result); - pragma Import (Ada, Result_Array); + Result : chars_ptr; + begin + for C of Str loop + if C = ASCII.NUL then + exit; + end if; + Len := Len + 1; + end loop; - Count : size_t; + Result := Memory_Alloc (size_t (Len) + 1); + + declare + Result_Array : char_array (1 .. size_t (Len) + 1) + with Address => To_Address (Result), Import, Convention => Ada; + + Count : size_t; + begin + To_C + (Item => Str (Str'First .. Str'First + Len - 1), + Target => Result_Array, + Count => Count, + Append_Nul => True); + end; - begin - To_C - (Item => Str, - Target => Result_Array, - Count => Count, - Append_Nul => True); return Result; end New_String; @@ -187,19 +205,19 @@ is -- Position_Of_Nul -- --------------------- - function Position_Of_Nul (Into : char_array) return size_t is + procedure Position_Of_Nul + (Into : char_array; Found : out Boolean; Index : out size_t) is begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); + Found := False; + Index := 0; + for J in Into'Range loop if Into (J) = nul then - return J; + Found := True; + Index := J; + return; end if; end loop; - - return Into'Last + 1; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Position_Of_Nul; ------------ @@ -231,19 +249,22 @@ is (Item : char_array_access; Nul_Check : Boolean := False) return chars_ptr is + Found : Boolean; + Index : size_t; begin pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", "early returns for performance"); if Item = null then return Null_Ptr; - elsif Nul_Check - and then Position_Of_Nul (Into => Item.all) > Item'Last - then - raise Terminator_Error; - else - return To_chars_ptr (Item (Item'First)'Address); + elsif Nul_Check then + Position_Of_Nul (Item.all, Found, Index); + if not Found then + raise Terminator_Error; + end if; end if; + return To_chars_ptr (Item (Item'First)'Address); + pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end To_Chars_Ptr; @@ -260,6 +281,11 @@ is Index : chars_ptr := Item + Offset; begin + -- Check for null pointer as mandated by the RM. + if Item = Null_Ptr then + raise Dereference_Error; + end if; + if Check and then Offset + Chars'Length > Strlen (Item) then raise Update_Error; end if; diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb index e4140e8..dd2f150 100644 --- a/gcc/ada/libgnat/s-aridou.adb +++ b/gcc/ada/libgnat/s-aridou.adb @@ -29,74 +29,20 @@ -- -- ------------------------------------------------------------------------------ -pragma Annotate (Gnatcheck, Exempt_On, "Metrics_LSLOC", - "limit exceeded due to proof code"); - with Ada.Unchecked_Conversion; -with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations; package body System.Arith_Double with SPARK_Mode is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore); - pragma Suppress (Overflow_Check); pragma Suppress (Range_Check); - pragma Warnings - (Off, "statement has no effect", - Reason => "Ghost code on dead paths is used for verification only"); - function To_Uns is new Ada.Unchecked_Conversion (Double_Int, Double_Uns); function To_Int is new Ada.Unchecked_Conversion (Double_Uns, Double_Int); Double_Size : constant Natural := Double_Int'Size; Single_Size : constant Natural := Double_Int'Size / 2; - -- Log of Single_Size in base 2, so that Single_Size = 2 ** Log_Single_Size - Log_Single_Size : constant Natural := - (case Single_Size is - when 32 => 5, - when 64 => 6, - when 128 => 7, - when others => raise Program_Error) - with Ghost; - - -- Power-of-two constants - - pragma Warnings - (Off, "non-preelaborable call not allowed in preelaborated unit", - Reason => "Ghost code is not compiled"); - pragma Warnings - (Off, "non-static constant in preelaborated unit", - Reason => "Ghost code is not compiled"); - Big_0 : constant Big_Integer := - Big (Double_Uns'(0)) - with Ghost; - Big_2xxSingle : constant Big_Integer := - Big (Double_Int'(2 ** Single_Size)) - with Ghost; - Big_2xxDouble_Minus_1 : constant Big_Integer := - Big (Double_Uns'(2 ** (Double_Size - 1))) - with Ghost; - Big_2xxDouble : constant Big_Integer := - Big (Double_Uns'(2 ** Double_Size - 1)) + 1 - with Ghost; - pragma Warnings - (On, "non-preelaborable call not allowed in preelaborated unit"); - pragma Warnings (On, "non-static constant in preelaborated unit"); - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", "early returns for performance"); @@ -115,9 +61,7 @@ is -- Length doubling multiplication function "/" (A : Double_Uns; B : Single_Uns) return Double_Uns is - (A / Double_Uns (B)) - with - Pre => B /= 0; + (A / Double_Uns (B)); -- Length doubling division function "&" (Hi, Lo : Single_Uns) return Double_Uns is @@ -127,37 +71,15 @@ is function "abs" (X : Double_Int) return Double_Uns is (if X = Double_Int'First then Double_Uns'(2 ** (Double_Size - 1)) - else Double_Uns (Double_Int'(abs X))) - with Post => abs Big (X) = Big ("abs"'Result), - Annotate => (GNATprove, Hide_Info, "Expression_Function_Body"); + else Double_Uns (Double_Int'(abs X))); -- Convert absolute value of X to unsigned. Note that we can't just use -- the expression of the Else since it overflows for X = Double_Int'First. function "rem" (A : Double_Uns; B : Single_Uns) return Double_Uns is - (A rem Double_Uns (B)) - with - Pre => B /= 0; + (A rem Double_Uns (B)); -- Length doubling remainder - function Big_2xx (N : Natural) return Big_Positive is - (Big (Double_Uns'(2 ** N))) - with - Ghost, - Pre => N < Double_Size, - Post => Big_2xx'Result > 0; - -- 2**N as a big integer - - function Big3 (X1, X2, X3 : Single_Uns) return Big_Natural is - (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (X1)) - + Big_2xxSingle * Big (Double_Uns (X2)) - + Big (Double_Uns (X3))) - with - Ghost; - -- X1&X2&X3 as a big integer - - function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean - with - Post => Le3'Result = (Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3)); + function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean; -- Determines if (3 * Single_Size)-bit value X1&X2&X3 <= Y1&Y2&Y3 function Lo (A : Double_Uns) return Single_Uns is @@ -168,654 +90,41 @@ is (Single_Uns (Shift_Right (A, Single_Size))); -- High order half of double value - procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) - with - Pre => Big3 (X1, X2, X3) >= Big3 (Y1, Y2, Y3), - Post => Big3 (X1, X2, X3) = Big3 (X1, X2, X3)'Old - Big3 (Y1, Y2, Y3); + procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns); -- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 mod 2 ** (3 * Single_Size) - function To_Neg_Int (A : Double_Uns) return Double_Int - with - Pre => In_Double_Int_Range (-Big (A)), - Post => Big (To_Neg_Int'Result) = -Big (A); + function To_Neg_Int (A : Double_Uns) return Double_Int; -- Convert to negative integer equivalent. If the input is in the range -- 0 .. 2 ** (Double_Size - 1), then the corresponding nonpositive signed -- integer (obtained by negating the given value) is returned, otherwise -- constraint error is raised. - function To_Pos_Int (A : Double_Uns) return Double_Int - with - Pre => In_Double_Int_Range (Big (A)), - Post => Big (To_Pos_Int'Result) = Big (A); + function To_Pos_Int (A : Double_Uns) return Double_Int; -- Convert to positive integer equivalent. If the input is in the range -- 0 .. 2 ** (Double_Size - 1) - 1, then the corresponding non-negative -- signed integer is returned, otherwise constraint error is raised. - procedure Raise_Error with - Exceptional_Cases => (Constraint_Error => True); - pragma No_Return (Raise_Error); + procedure Raise_Error with No_Return; -- Raise constraint error with appropriate message - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Inline_Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => Le3 (X1, X2, X3, Y1, Y2, Y3), - Post => Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3); - - procedure Lemma_Abs_Commutation (X : Double_Int) - with - Ghost, - Post => abs Big (X) = Big (Double_Uns'(abs X)); - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X / Y) = abs X / abs Y; - - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) - with - Ghost, - Post => abs (X * Y) = abs X * abs Y; - - procedure Lemma_Abs_Range (X : Big_Integer) - with - Ghost, - Pre => In_Double_Int_Range (X), - Post => abs X <= Big_2xxDouble_Minus_1 - and then In_Double_Int_Range (-abs X); - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X rem Y) = (abs X) rem (abs Y); - - procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) - with - Ghost, - Pre => X <= 2 ** Double_Size - 2 ** Single_Size, - Post => Big (X) + Big (Double_Uns (Y)) = Big (X + Double_Uns (Y)); - - procedure Lemma_Add_One (X : Double_Uns) - with - Ghost, - Pre => X /= Double_Uns'Last, - Post => Big (X + Double_Uns'(1)) = Big (X) + 1; - - procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) - with - Ghost, - Post => Big (X) < Big_2xxDouble; - - procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) - with - Ghost, - Post => Big (Double_Uns (X)) >= 0 - and then Big (Double_Uns (X)) < Big_2xxSingle; - - procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) - with - Ghost, - Pre => M < N and then N < Double_Size, - Post => Double_Uns'(2)**M < Double_Uns'(2)**N; - - procedure Lemma_Concat_Definition (X, Y : Single_Uns) - with - Ghost, - Post => Big (X & Y) = Big_2xxSingle * Big (Double_Uns (X)) - + Big (Double_Uns (Y)); - - procedure Lemma_Deep_Mult_Commutation - (Factor : Big_Integer; - X, Y : Single_Uns) - with - Ghost, - Post => - Factor * Big (Double_Uns (X)) * Big (Double_Uns (Y)) = - Factor * Big (Double_Uns (X) * Double_Uns (Y)); - - procedure Lemma_Div_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Definition - (A : Double_Uns; - B : Single_Uns; - Q : Double_Uns; - R : Double_Uns) - with - Ghost, - Pre => B /= 0 and then Q = A / B and then R = A rem B, - Post => Big (A) = Big (Double_Uns (B)) * Big (Q) + Big (R); - - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Z > 0 and then X >= Y * Z, - Post => X / Z >= Y; - - procedure Lemma_Div_Lt (X, Y, Z : Big_Natural) - with - Ghost, - Pre => Z > 0 and then X < Y * Z, - Post => X / Z < Y; - - procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) - with - Ghost, - Pre => A * S = B * S + R and then S /= 0, - Post => A = B + R / S; - - procedure Lemma_Div_Mult (X : Big_Natural; Y : Big_Positive) - with - Ghost, - Post => X / Y * Y > X - Y; - - procedure Lemma_Double_Big_2xxSingle - with - Ghost, - Post => Big_2xxSingle * Big_2xxSingle = Big_2xxDouble; - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Left (Shift_Left (X, Natural (S)), Natural (S1)) = - Shift_Left (X, Natural (S + S1)); - - procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Single_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Left (Shift_Left (X, Natural (S)), Natural (S1)) = - Shift_Left (X, Natural (S + S1)); - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Right (Shift_Right (X, Natural (S)), Natural (S1)) = - Shift_Right (X, Natural (S + S1)); - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Right (Shift_Right (X, S), S1) = Shift_Right (X, S + S1); - - procedure Lemma_Ge_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A >= B, - Post => Big (A) >= Big (B); - - procedure Lemma_Ge_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A >= B and then B * C >= D and then C > 0, - Post => A * C >= D; - - procedure Lemma_Gt_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A > B, - Post => Big (A) > Big (B); - - procedure Lemma_Gt_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A >= B and then B * C > D and then C > 0, - Post => A * C > D; - - procedure Lemma_Hi_Lo (Xu : Double_Uns; Xhi, Xlo : Single_Uns) - with - Ghost, - Pre => Xhi = Hi (Xu) and Xlo = Lo (Xu), - Post => Big (Xu) = - Big_2xxSingle * Big (Double_Uns (Xhi)) + Big (Double_Uns (Xlo)); - - procedure Lemma_Hi_Lo_3 (Xu : Double_Uns; Xhi, Xlo : Single_Uns) - with - Ghost, - Pre => Xhi = Hi (Xu) and then Xlo = Lo (Xu), - Post => Big (Xu) = Big3 (0, Xhi, Xlo); - - procedure Lemma_Lo_Is_Ident (X : Double_Uns) - with - Ghost, - Pre => Big (X) < Big_2xxSingle, - Post => Double_Uns (Lo (X)) = X; - - procedure Lemma_Lt_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A < B, - Post => Big (A) < Big (B); - - procedure Lemma_Lt_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A < B and then B * C <= D and then C > 0, - Post => A * C < D; - - procedure Lemma_Mult_Commutation (X, Y : Single_Uns) - with - Ghost, - Post => - Big (Double_Uns (X)) * Big (Double_Uns (Y)) = - Big (Double_Uns (X) * Double_Uns (Y)); - - procedure Lemma_Mult_Commutation (X, Y : Double_Int) - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)), - Post => Big (X) * Big (Y) = Big (X * Y); - - procedure Lemma_Mult_Commutation (X, Y, Z : Double_Uns) - with - Ghost, - Pre => Big (X) * Big (Y) < Big_2xxDouble and then Z = X * Y, - Post => Big (X) * Big (Y) = Big (Z); - - procedure Lemma_Mult_Decomposition - (Mult : Big_Integer; - Xu, Yu : Double_Uns; - Xhi, Xlo, Yhi, Ylo : Single_Uns) - with - Ghost, - Pre => Mult = Big (Xu) * Big (Yu) - and then Xhi = Hi (Xu) - and then Xlo = Lo (Xu) - and then Yhi = Hi (Yu) - and then Ylo = Lo (Yu), - Post => Mult = - Big_2xxSingle * Big_2xxSingle * (Big (Double_Uns'(Xhi * Yhi))) - + Big_2xxSingle * (Big (Double_Uns'(Xhi * Ylo))) - + Big_2xxSingle * (Big (Double_Uns'(Xlo * Yhi))) - + (Big (Double_Uns'(Xlo * Ylo))); - - procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) - with - Ghost, - Post => X * (Y + Z) = X * Y + X * Z; - - procedure Lemma_Mult_Div (A, B : Big_Integer) - with - Ghost, - Pre => B /= 0, - Post => A * B / B = A; - - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) - with - Ghost, - Pre => (X >= 0 and then Y >= 0) - or else (X <= 0 and then Y <= 0), - Post => X * Y >= 0; - - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X <= Big_0 and then Y >= Big_0) - or else (X >= Big_0 and then Y <= Big_0), - Post => X * Y <= Big_0; - - procedure Lemma_Mult_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X > Big_0 and then Y > Big_0) - or else (X < Big_0 and then Y < Big_0), - Post => X * Y > Big_0; - - procedure Lemma_Neg_Div (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X / Y = (-X) / (-Y); - - procedure Lemma_Neg_Rem (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (-Y); - - procedure Lemma_Not_In_Range_Big2xx64 - with - Post => not In_Double_Int_Range (Big_2xxDouble) - and then not In_Double_Int_Range (-Big_2xxDouble); - - procedure Lemma_Powers (A : Big_Natural; B, C : Natural) - with - Ghost, - Pre => B <= Natural'Last - C, - Post => A**B * A**C = A**(B + C); - - procedure Lemma_Powers_Of_2 (M, N : Natural) - with - Ghost, - Pre => M < Double_Size - and then N < Double_Size - and then M + N <= Double_Size, - Post => - Big_2xx (M) * Big_2xx (N) = - (if M + N = Double_Size then Big_2xxDouble else Big_2xx (M + N)); - - procedure Lemma_Powers_Of_2_Commutation (M : Natural) - with - Ghost, - Subprogram_Variant => (Decreases => M), - Pre => M <= Double_Size, - Post => Big (Double_Uns'(2))**M = - (if M < Double_Size then Big_2xx (M) else Big_2xxDouble); - - procedure Lemma_Powers_Of_2_Increasing (M, N : Natural) - with - Ghost, - Subprogram_Variant => (Increases => M), - Pre => M < N, - Post => Big (Double_Uns'(2))**M < Big (Double_Uns'(2))**N; - - procedure Lemma_Rem_Abs (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (abs Y); - pragma Unreferenced (Lemma_Rem_Abs); - - procedure Lemma_Rem_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) rem Big (Y) = Big (X rem Y); - - procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer) - with - Ghost, - Pre => abs X < abs Y, - Post => X rem Y = X; - pragma Unreferenced (Lemma_Rem_Is_Ident); - - procedure Lemma_Rem_Sign (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => Same_Sign (X rem Y, X); - pragma Unreferenced (Lemma_Rem_Sign); - - procedure Lemma_Rev_Div_Definition (A, B, Q, R : Big_Natural) - with - Ghost, - Pre => A = B * Q + R and then R < B, - Post => Q = A / B and then R = A rem B; - - procedure Lemma_Shift_Left (X : Double_Uns; Shift : Natural) - with - Ghost, - Pre => Shift < Double_Size - and then Big (X) * Big_2xx (Shift) < Big_2xxDouble, - Post => Big (Shift_Left (X, Shift)) = Big (X) * Big_2xx (Shift); - - procedure Lemma_Shift_Right (X : Double_Uns; Shift : Natural) - with - Ghost, - Pre => Shift < Double_Size, - Post => Big (Shift_Right (X, Shift)) = Big (X) / Big_2xx (Shift); - - procedure Lemma_Shift_Without_Drop - (X, Y : Double_Uns; - Mask : Single_Uns; - Shift : Natural) - with - Ghost, - Pre => (Hi (X) and Mask) = 0 -- X has the first Shift bits off - and then Shift <= Single_Size - and then Mask = Shift_Left (Single_Uns'Last, Single_Size - Shift) - and then Y = Shift_Left (X, Shift), - Post => Big (Y) = Big_2xx (Shift) * Big (X); - - procedure Lemma_Simplify (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X * Y / Y = X; - - procedure Lemma_Substitution (A, B, C, C1, D : Big_Integer) - with - Ghost, - Pre => C = C1 and then A = B * C + D, - Post => A = B * C1 + D; - - procedure Lemma_Subtract_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => X >= Y, - Post => Big (X) - Big (Y) = Big (X - Y); - - procedure Lemma_Subtract_Double_Uns (X, Y : Double_Int) - with - Ghost, - Pre => X >= 0 and then X <= Y, - Post => Double_Uns (Y - X) = Double_Uns (Y) - Double_Uns (X); - - procedure Lemma_Word_Commutation (X : Single_Uns) - with - Ghost, - Post => Big_2xxSingle * Big (Double_Uns (X)) - = Big (2**Single_Size * Double_Uns (X)); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Inline_Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is null; - procedure Lemma_Abs_Commutation (X : Double_Int) is null; - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Abs_Range (X : Big_Integer) is null; - procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) is null; - procedure Lemma_Add_One (X : Double_Uns) is null; - procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) is null; - procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) is null; - procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) is null; - procedure Lemma_Deep_Mult_Commutation - (Factor : Big_Integer; - X, Y : Single_Uns) - is null; - procedure Lemma_Div_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Div_Definition - (A : Double_Uns; - B : Single_Uns; - Q : Double_Uns; - R : Double_Uns) - is null; - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null; - procedure Lemma_Div_Lt (X, Y, Z : Big_Natural) is null; - procedure Lemma_Div_Mult (X : Big_Natural; Y : Big_Positive) is null; - procedure Lemma_Double_Big_2xxSingle is null; - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns) is null; - procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural) is null; - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Double_Uns) - is null; - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Double_Uns) - is null; - procedure Lemma_Ge_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Ge_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Gt_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Gt_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Lo_Is_Ident (X : Double_Uns) is null; - procedure Lemma_Lt_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Lt_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Mult_Commutation (X, Y : Single_Uns) is null; - procedure Lemma_Mult_Commutation (X, Y : Double_Int) is null; - procedure Lemma_Mult_Commutation (X, Y, Z : Double_Uns) is null; - procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) is null; - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; - procedure Lemma_Not_In_Range_Big2xx64 is null; - procedure Lemma_Powers (A : Big_Natural; B, C : Natural) is null; - procedure Lemma_Rem_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer) is null; - procedure Lemma_Rem_Sign (X, Y : Big_Integer) is null; - procedure Lemma_Rev_Div_Definition (A, B, Q, R : Big_Natural) is null; - procedure Lemma_Simplify (X, Y : Big_Integer) is null; - procedure Lemma_Substitution (A, B, C, C1, D : Big_Integer) is null; - procedure Lemma_Subtract_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Subtract_Double_Uns (X, Y : Double_Int) is null; - procedure Lemma_Word_Commutation (X : Single_Uns) is null; - -------------------------- -- Add_With_Ovflo_Check -- -------------------------- function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is R : constant Double_Int := To_Int (To_Uns (X) + To_Uns (Y)); - - -- Local lemmas - - procedure Prove_Negative_X - with - Ghost, - Pre => X < 0 and then (Y > 0 or else R < 0), - Post => R = X + Y; - - procedure Prove_Non_Negative_X - with - Ghost, - Pre => X >= 0 and then (Y < 0 or else R >= 0), - Post => R = X + Y; - - procedure Prove_Overflow_Case - with - Ghost, - Pre => - (if X >= 0 then Y >= 0 and then R < 0 - else Y <= 0 and then R >= 0), - Post => not In_Double_Int_Range (Big (X) + Big (Y)); - - ---------------------- - -- Prove_Negative_X -- - ---------------------- - - procedure Prove_Negative_X is - begin - if X = Double_Int'First then - if Y > 0 then - null; - else - pragma Assert - (To_Uns (X) + To_Uns (Y) = - 2 ** (Double_Size - 1) - Double_Uns (-Y)); - pragma Assert -- as R < 0 - (To_Uns (X) + To_Uns (Y) >= 2 ** (Double_Size - 1)); - pragma Assert (Y = 0); - end if; - - elsif Y = Double_Int'First then - pragma Assert - (To_Uns (X) + To_Uns (Y) = - 2 ** (Double_Size - 1) - Double_Uns (-X)); - pragma Assert (False); - - elsif Y <= 0 then - pragma Assert - (To_Uns (X) + To_Uns (Y) = -Double_Uns (-X) - Double_Uns (-Y)); - - else -- Y > 0, 0 > X > Double_Int'First - declare - Ru : constant Double_Uns := To_Uns (X) + To_Uns (Y); - begin - pragma Assert (Ru = -Double_Uns (-X) + Double_Uns (Y)); - if Ru < 2 ** (Double_Size - 1) then -- R >= 0 - Lemma_Subtract_Double_Uns (-X, Y); - pragma Assert (Ru = Double_Uns (X + Y)); - - elsif Ru = 2 ** (Double_Size - 1) then - pragma Assert (Double_Uns (Y) < 2 ** (Double_Size - 1)); - pragma Assert (Double_Uns (-X) < 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (R = -Double_Int (-(-Double_Uns (-X) + Double_Uns (Y)))); - pragma Assert - (R = -Double_Int (-Double_Uns (Y) + Double_Uns (-X))); - end if; - end; - end if; - end Prove_Negative_X; - - -------------------------- - -- Prove_Non_Negative_X -- - -------------------------- - - procedure Prove_Non_Negative_X is - begin - if Y >= 0 or else Y = Double_Int'First then - null; - else - pragma Assert - (To_Uns (X) + To_Uns (Y) = Double_Uns (X) - Double_Uns (-Y)); - end if; - end Prove_Non_Negative_X; - - ------------------------- - -- Prove_Overflow_Case -- - ------------------------- - - procedure Prove_Overflow_Case is - begin - if X < 0 and then X /= Double_Int'First and then Y /= Double_Int'First - then - pragma Assert - (To_Uns (X) + To_Uns (Y) = -Double_Uns (-X) - Double_Uns (-Y)); - end if; - end Prove_Overflow_Case; - - -- Start of processing for Add_With_Ovflo_Check - begin if X >= 0 then if Y < 0 or else R >= 0 then - Prove_Non_Negative_X; return R; end if; else -- X < 0 if Y > 0 or else R < 0 then - Prove_Negative_X; return R; end if; end if; - Prove_Overflow_Case; Raise_Error; end Add_With_Ovflo_Check; @@ -823,8 +132,6 @@ is -- Double_Divide -- ------------------- - pragma Annotate (Gnatcheck, Exempt_On, "Metrics_Cyclomatic_Complexity", - "limit exceeded due to proof code"); procedure Double_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; @@ -844,183 +151,11 @@ is Du, Qu, Ru : Double_Uns; Den_Pos : constant Boolean := (Y < 0) = (Z < 0); - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (Y) * Big (Z)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - - -- Local lemmas - - procedure Prove_Overflow_Case - with - Ghost, - Pre => X = Double_Int'First and then Big (Y) * Big (Z) = -1, - Post => not In_Double_Int_Range (Big (X) / (Big (Y) * Big (Z))) - and then not In_Double_Int_Range - (Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z)))); - -- Proves the special case where -2**(Double_Size - 1) is divided by -1, - -- generating an overflow. - - procedure Prove_Quotient_Zero - with - Ghost, - Pre => Mult >= Big_2xxDouble - and then - not (Mult = Big_2xxDouble - and then X = Double_Int'First - and then Round) - and then Q = 0 - and then R = X, - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)) - else Big (Q) = Big (X) / (Big (Y) * Big (Z))); - -- Proves the general case where divisor doesn't fit in Double_Uns and - -- quotient is 0. - - procedure Prove_Round_To_One - with - Ghost, - Pre => Mult = Big_2xxDouble - and then X = Double_Int'First - and then Q = (if Den_Pos then -1 else 1) - and then R = X - and then Round, - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)); - -- Proves the special case where the divisor doesn't fit in Double_Uns - -- but quotient is still 1 or -1 due to rounding - -- (abs (Y*Z) = 2**Double_Size and X = -2**(Double_Size - 1) and Round). - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Du) = Mult - and then Big (Qu) = - (if Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot), - Post => abs Big_Q = Big (Qu); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Sign_Quotient - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - (if Round then - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - else Quot), - Post => - (if X >= 0 then - (if Den_Pos then Big_Q >= 0 else Big_Q <= 0) - else - (if Den_Pos then Big_Q <= 0 else Big_Q >= 0)); - -- Proves the correct sign of the signed quotient Big_Q - - procedure Prove_Signs - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - (if Round then - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then R = (if X >= 0 then To_Int (Ru) else To_Int (-Ru)) - and then - Q = (if (X >= 0) = Den_Pos then To_Int (Qu) else To_Int (-Qu)) - and then not (X = Double_Int'First and then Big (Y) * Big (Z) = -1), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)) - else Big (Q) = Big (X) / (Big (Y) * Big (Z))); - -- Proves final signs match the intended result after the unsigned - -- division is done. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Overflow_Case is null; - procedure Prove_Quotient_Zero is null; - procedure Prove_Round_To_One is null; - procedure Prove_Sign_Quotient is null; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X), Big (Y) * Big (Z)) then - pragma Assert (abs Big_Q = Big (Qu)); - end if; - end Prove_Rounding_Case; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is - begin - if (X >= 0) = Den_Pos then - pragma Assert (Quot >= 0); - pragma Assert (Big_Q >= 0); - pragma Assert (Q >= 0); - pragma Assert (Big (Q) = Big_Q); - else - pragma Assert ((X >= 0) /= (Big (Y) * Big (Z) >= 0)); - pragma Assert (Quot <= 0); - pragma Assert (Big_Q <= 0); - pragma Assert (if X >= 0 then R >= 0); - pragma Assert (if X < 0 then R <= 0); - pragma Assert (Big (R) = Big_R); - end if; - end Prove_Signs; - - -- Start of processing for Double_Divide - begin if Yu = 0 or else Zu = 0 then Raise_Error; end if; - pragma Assert (Mult /= 0); - pragma Assert (Den_Pos = (Big (Y) * Big (Z) > 0)); - Quot := Big (X) / (Big (Y) * Big (Z)); - Big_R := Big (X) rem (Big (Y) * Big (Z)); - if Round then - Big_Q := Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - Lemma_Abs_Mult_Commutation (Big (Y), Big (Z)); - Lemma_Mult_Decomposition (Mult, Yu, Zu, Yhi, Ylo, Zhi, Zlo); - -- Compute Y * Z. Note that if the result overflows Double_Uns, then -- the rounded result is zero, except for the very special case where -- X = -2 ** (Double_Size - 1) and abs (Y * Z) = 2 ** Double_Size, when @@ -1040,66 +175,21 @@ is and then Round then Q := (if Den_Pos then -1 else 1); - - Prove_Round_To_One; - else Q := 0; - - pragma Assert (Double_Uns'(Yhi * Zhi) >= Double_Uns (Yhi)); - pragma Assert (Double_Uns'(Yhi * Zhi) >= Double_Uns (Zhi)); - pragma Assert (Big (Double_Uns'(Yhi * Zhi)) >= 1); - if Yhi > 1 or else Zhi > 1 then - pragma Assert (Big (Double_Uns'(Yhi * Zhi)) > 1); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Zlo > 0 then - pragma Assert (Big (Double_Uns'(Yhi * Zlo)) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Ylo > 0 then - pragma Assert (Double_Uns'(Ylo * Zhi) > 0); - pragma Assert (Big (Double_Uns'(Ylo * Zhi)) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - else - pragma Assert (not (X = Double_Int'First and then Round)); - end if; - Prove_Quotient_Zero; end if; return; else T2 := Yhi * Zlo; - pragma Assert (Big (T2) = Big (Double_Uns'(Yhi * Zlo))); - pragma Assert (Big_0 = Big (Double_Uns'(Ylo * Zhi))); end if; - else T2 := Ylo * Zhi; - pragma Assert (Big (T2) = Big (Double_Uns'(Ylo * Zhi))); - pragma Assert (Big_0 = Big (Double_Uns'(Yhi * Zlo))); end if; T1 := Ylo * Zlo; - - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns'(Yhi * Zlo)), - Big (Double_Uns'(Ylo * Zhi))); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (T2), - Big (Double_Uns (Hi (T1)))); - Lemma_Add_Commutation (T2, Hi (T1)); - T2 := T2 + Hi (T1); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (Hi (T2))), - Big (Double_Uns (Lo (T2)))); - Lemma_Double_Big_2xxSingle; - if Hi (T2) /= 0 then R := X; @@ -1112,41 +202,8 @@ is and then Round then Q := (if Den_Pos then -1 else 1); - - Prove_Round_To_One; - else Q := 0; - - pragma Assert (Big (Double_Uns (Hi (T2))) >= 1); - pragma Assert (Big (Double_Uns (Lo (T2))) >= 0); - pragma Assert (Big (Double_Uns (Lo (T1))) >= 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1))) >= 0); - pragma Assert (Mult >= Big_2xxDouble * Big (Double_Uns (Hi (T2)))); - pragma Assert (Mult >= Big_2xxDouble); - if Hi (T2) > 1 then - pragma Assert (Big (Double_Uns (Hi (T2))) > 1); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Lo (T2) > 0 then - pragma Assert (Big (Double_Uns (Lo (T2))) > 0); - pragma Assert (Big_2xxSingle > 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) > 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1))) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Lo (T1) > 0 then - pragma Assert (Double_Uns (Lo (T1)) > 0); - Lemma_Gt_Commutation (Double_Uns (Lo (T1)), 0); - pragma Assert (Big (Double_Uns (Lo (T1))) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - else - pragma Assert (not (X = Double_Int'First and then Round)); - end if; - Prove_Quotient_Zero; end if; return; @@ -1154,22 +211,9 @@ is Du := Lo (T2) & Lo (T1); - Lemma_Hi_Lo (Du, Lo (T2), Lo (T1)); - pragma Assert (Mult = Big (Du)); - pragma Assert (Du /= 0); - -- Multiplication of 2-limb arguments Yu and Zu leads to 4-limb result - -- (where each limb is a single value). Cases where 4 limbs are needed - -- require Yhi /= 0 and Zhi /= 0 and lead to early exit. Remaining cases - -- where 3 limbs are needed correspond to Hi(T2) /= 0 and lead to early - -- exit. Thus, at this point, the result fits in 2 limbs which are - -- exactly Lo (T2) and Lo (T1), which corresponds to the value of Du. - -- As the case where one of Yu or Zu is null also led to early exit, - -- we have Du /= 0 here. - -- Check overflow case of largest negative number divided by -1 if X = Double_Int'First and then Du = 1 and then not Den_Pos then - Prove_Overflow_Case; Raise_Error; end if; @@ -1188,29 +232,14 @@ is Qu := Xu / Du; Ru := Xu rem Du; - Lemma_Div_Commutation (Xu, Du); - Lemma_Abs_Div_Commutation (Big (X), Big (Y) * Big (Z)); - Lemma_Abs_Commutation (X); - pragma Assert (abs Quot = Big (Qu)); - Lemma_Rem_Commutation (Xu, Du); - Lemma_Abs_Rem_Commutation (Big (X), Big (Y) * Big (Z)); - pragma Assert (abs Big_R = Big (Ru)); - -- Deal with rounding case if Round then if Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) then - Lemma_Add_Commutation (Qu, 1); - Qu := Qu + Double_Uns'(1); end if; - - Prove_Rounding_Case; end if; - pragma Assert (abs Big_Q = Big (Qu)); - Prove_Sign_Quotient; - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X) sign positive @@ -1229,10 +258,7 @@ is R := To_Int (-Ru); Q := (if Den_Pos then To_Int (-Qu) else To_Int (Qu)); end if; - - Prove_Signs; end Double_Divide; - pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_Cyclomatic_Complexity"); --------- -- Le3 -- @@ -1254,418 +280,6 @@ is end Le3; ------------------------------- - -- Lemma_Abs_Div_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - if X < 0 then - pragma Assert (abs (X / Y) = abs (X / (-Y))); - else - Lemma_Neg_Div (X, Y); - pragma Assert (abs (X / Y) = abs ((-X) / (-Y))); - end if; - end if; - end Lemma_Abs_Div_Commutation; - - ------------------------------- - -- Lemma_Abs_Rem_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - Lemma_Neg_Rem (X, Y); - if X < 0 then - pragma Assert (X rem Y = -((-X) rem (-Y))); - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - else - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - end if; - end if; - end Lemma_Abs_Rem_Commutation; - - ----------------------------- - -- Lemma_Concat_Definition -- - ----------------------------- - - procedure Lemma_Concat_Definition (X, Y : Single_Uns) is - Hi : constant Double_Uns := Shift_Left (Double_Uns (X), Single_Size); - Lo : constant Double_Uns := Double_Uns (Y); - begin - pragma Assert (Hi = Double_Uns'(2 ** Single_Size) * Double_Uns (X)); - pragma Assert ((Hi or Lo) = Hi + Lo); - end Lemma_Concat_Definition; - - ------------------ - -- Lemma_Div_Eq -- - ------------------ - - procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) is - begin - pragma Assert ((A - B) * S = R); - pragma Assert ((A - B) * S / S = R / S); - Lemma_Mult_Div (A - B, S); - pragma Assert (A - B = R / S); - end Lemma_Div_Eq; - - ------------------------ - -- Lemma_Double_Shift -- - ------------------------ - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Left (Shift_Left (X, S), S1) - = Shift_Left (Shift_Left (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Left (X, S + S1) - = Shift_Left (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift; - - ----------------------------- - -- Lemma_Double_Shift_Left -- - ----------------------------- - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift_Left (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Left (Shift_Left (X, S), S1) - = Shift_Left (Shift_Left (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Left (X, S + S1) - = Shift_Left (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift_Left; - - ------------------------------ - -- Lemma_Double_Shift_Right -- - ------------------------------ - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift_Right (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Right (Shift_Right (X, S), S1) - = Shift_Right (Shift_Right (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Right (X, S + S1) - = Shift_Right (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift_Right; - - ----------------- - -- Lemma_Hi_Lo -- - ----------------- - - procedure Lemma_Hi_Lo (Xu : Double_Uns; Xhi, Xlo : Single_Uns) is - begin - pragma Assert (Double_Uns (Xhi) = Xu / Double_Uns'(2 ** Single_Size)); - pragma Assert (Double_Uns (Xlo) = Xu mod 2 ** Single_Size); - end Lemma_Hi_Lo; - - ------------------- - -- Lemma_Hi_Lo_3 -- - ------------------- - - procedure Lemma_Hi_Lo_3 (Xu : Double_Uns; Xhi, Xlo : Single_Uns) is - begin - Lemma_Hi_Lo (Xu, Xhi, Xlo); - end Lemma_Hi_Lo_3; - - ------------------------------ - -- Lemma_Mult_Decomposition -- - ------------------------------ - - procedure Lemma_Mult_Decomposition - (Mult : Big_Integer; - Xu, Yu : Double_Uns; - Xhi, Xlo, Yhi, Ylo : Single_Uns) - is - begin - Lemma_Hi_Lo (Xu, Xhi, Xlo); - Lemma_Hi_Lo (Yu, Yhi, Ylo); - - pragma Assert - (Mult = - (Big_2xxSingle * Big (Double_Uns (Xhi)) + Big (Double_Uns (Xlo))) * - (Big_2xxSingle * Big (Double_Uns (Yhi)) + Big (Double_Uns (Ylo)))); - pragma Assert (Mult = - Big_2xxSingle - * Big_2xxSingle * Big (Double_Uns (Xhi)) * Big (Double_Uns (Yhi)) - + Big_2xxSingle * Big (Double_Uns (Xhi)) * Big (Double_Uns (Ylo)) - + Big_2xxSingle * Big (Double_Uns (Xlo)) * Big (Double_Uns (Yhi)) - + Big (Double_Uns (Xlo)) * Big (Double_Uns (Ylo))); - Lemma_Deep_Mult_Commutation (Big_2xxSingle * Big_2xxSingle, Xhi, Yhi); - Lemma_Deep_Mult_Commutation (Big_2xxSingle, Xhi, Ylo); - Lemma_Deep_Mult_Commutation (Big_2xxSingle, Xlo, Yhi); - Lemma_Mult_Commutation (Xlo, Ylo); - pragma Assert (Mult = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns'(Xhi * Yhi)) - + Big_2xxSingle * Big (Double_Uns'(Xhi * Ylo)) - + Big_2xxSingle * Big (Double_Uns'(Xlo * Yhi)) - + Big (Double_Uns'(Xlo * Ylo))); - end Lemma_Mult_Decomposition; - - -------------------- - -- Lemma_Mult_Div -- - -------------------- - - procedure Lemma_Mult_Div (A, B : Big_Integer) is - begin - if B > 0 then - pragma Assert (A * B / B = A); - else - pragma Assert (A * (-B) / (-B) = A); - end if; - end Lemma_Mult_Div; - - ------------------- - -- Lemma_Neg_Div -- - ------------------- - - procedure Lemma_Neg_Div (X, Y : Big_Integer) is - begin - pragma Assert ((-X) / (-Y) = -(X / (-Y))); - pragma Assert (X / (-Y) = -(X / Y)); - end Lemma_Neg_Div; - - ----------------------- - -- Lemma_Powers_Of_2 -- - ----------------------- - - procedure Lemma_Powers_Of_2 (M, N : Natural) is - begin - if M + N < Double_Size then - pragma Assert (Double_Uns'(2**M) * Double_Uns'(2**N) - = Double_Uns'(2**(M + N))); - end if; - - Lemma_Powers_Of_2_Commutation (M); - Lemma_Powers_Of_2_Commutation (N); - Lemma_Powers_Of_2_Commutation (M + N); - Lemma_Powers (Big (Double_Uns'(2)), M, N); - - if M + N < Double_Size then - pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N - = Big (Double_Uns'(2))**(M + N)); - Lemma_Powers_Of_2_Increasing (M + N, Double_Size); - Lemma_Mult_Commutation (2 ** M, 2 ** N, 2 ** (M + N)); - else - pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N - = Big (Double_Uns'(2))**(M + N)); - end if; - end Lemma_Powers_Of_2; - - ----------------------------------- - -- Lemma_Powers_Of_2_Commutation -- - ----------------------------------- - - procedure Lemma_Powers_Of_2_Commutation (M : Natural) is - begin - if M > 0 then - Lemma_Powers_Of_2_Commutation (M - 1); - pragma Assert (Big (Double_Uns'(2))**(M - 1) = Big_2xx (M - 1)); - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M - 1) * 2); - if M < Double_Size then - Lemma_Powers_Of_2_Increasing (M - 1, Double_Size - 1); - Lemma_Bounded_Powers_Of_2_Increasing (M - 1, Double_Size - 1); - pragma Assert (Double_Uns'(2 ** (M - 1)) * 2 = Double_Uns'(2**M)); - Lemma_Mult_Commutation - (Double_Uns'(2 ** (M - 1)), 2, Double_Uns'(2**M)); - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M)); - end if; - else - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M)); - end if; - end Lemma_Powers_Of_2_Commutation; - - ---------------------------------- - -- Lemma_Powers_Of_2_Increasing -- - ---------------------------------- - - procedure Lemma_Powers_Of_2_Increasing (M, N : Natural) is - begin - if M + 1 < N then - Lemma_Powers_Of_2_Increasing (M + 1, N); - end if; - end Lemma_Powers_Of_2_Increasing; - - ------------------- - -- Lemma_Rem_Abs -- - ------------------- - - procedure Lemma_Rem_Abs (X, Y : Big_Integer) is - begin - Lemma_Neg_Rem (X, Y); - end Lemma_Rem_Abs; - - ---------------------- - -- Lemma_Shift_Left -- - ---------------------- - - procedure Lemma_Shift_Left (X : Double_Uns; Shift : Natural) is - - procedure Lemma_Mult_Pow2 (X : Double_Uns; I : Natural) - with - Ghost, - Pre => I < Double_Size - 1, - Post => X * Double_Uns'(2) ** I * Double_Uns'(2) - = X * Double_Uns'(2) ** (I + 1); - - procedure Lemma_Mult_Pow2 (X : Double_Uns; I : Natural) is - Mul1 : constant Double_Uns := Double_Uns'(2) ** I; - Mul2 : constant Double_Uns := Double_Uns'(2); - Left : constant Double_Uns := X * Mul1 * Mul2; - begin - pragma Assert (Left = X * (Mul1 * Mul2)); - pragma Assert (Mul1 * Mul2 = Double_Uns'(2) ** (I + 1)); - end Lemma_Mult_Pow2; - - XX : Double_Uns := X; - - begin - for J in 1 .. Shift loop - declare - Cur_XX : constant Double_Uns := XX; - begin - XX := Shift_Left (XX, 1); - pragma Assert (XX = Cur_XX * Double_Uns'(2)); - Lemma_Mult_Pow2 (X, J - 1); - end; - Lemma_Double_Shift_Left (X, J - 1, 1); - pragma Loop_Invariant (XX = Shift_Left (X, J)); - pragma Loop_Invariant (XX = X * Double_Uns'(2) ** J); - end loop; - end Lemma_Shift_Left; - - ----------------------- - -- Lemma_Shift_Right -- - ----------------------- - - procedure Lemma_Shift_Right (X : Double_Uns; Shift : Natural) is - - procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural) - with - Ghost, - Pre => I < Double_Size - 1, - Post => X / Double_Uns'(2) ** I / Double_Uns'(2) - = X / Double_Uns'(2) ** (I + 1); - - procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) - with - Ghost, - Pre => Div /= 0 - and then X = Q * Div + R - and then Q <= Double_Uns'Last / Div - and then R <= Double_Uns'Last - Q * Div - and then R < Div, - Post => Q = X / Div; - pragma Annotate (GNATprove, False_Positive, "postcondition might fail", - "Q is the quotient of X by Div"); - - procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural) is - - -- Local lemmas - - procedure Lemma_Mult_Le (X, Y, Z : Double_Uns) - with - Ghost, - Pre => X <= 1, - Post => X * Z <= Z; - - procedure Lemma_Mult_Le (X, Y, Z : Double_Uns) is null; - - -- Local variables - - Div1 : constant Double_Uns := Double_Uns'(2) ** I; - Div2 : constant Double_Uns := Double_Uns'(2); - Left : constant Double_Uns := X / Div1 / Div2; - R2 : constant Double_Uns := X / Div1 - Left * Div2; - pragma Assert (R2 <= Div2 - 1); - R1 : constant Double_Uns := X - X / Div1 * Div1; - pragma Assert (R1 < Div1); - - -- Start of processing for Lemma_Div_Pow2 - - begin - pragma Assert (X = Left * (Div1 * Div2) + R2 * Div1 + R1); - Lemma_Mult_Le (R2, Div2 - 1, Div1); - pragma Assert (R2 * Div1 + R1 < Div1 * Div2); - Lemma_Quot_Rem (X, Div1 * Div2, Left, R2 * Div1 + R1); - pragma Assert (Left = X / (Div1 * Div2)); - pragma Assert (Div1 * Div2 = Double_Uns'(2) ** (I + 1)); - end Lemma_Div_Pow2; - - procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) is null; - - XX : Double_Uns := X; - - begin - for J in 1 .. Shift loop - declare - Cur_XX : constant Double_Uns := XX; - begin - XX := Shift_Right (XX, 1); - pragma Assert (XX = Cur_XX / Double_Uns'(2)); - Lemma_Div_Pow2 (X, J - 1); - end; - Lemma_Double_Shift_Right (X, J - 1, 1); - pragma Loop_Invariant (XX = Shift_Right (X, J)); - pragma Loop_Invariant (XX = X / Double_Uns'(2) ** J); - end loop; - Lemma_Div_Commutation (X, Double_Uns'(2) ** Shift); - end Lemma_Shift_Right; - - ------------------------------ - -- Lemma_Shift_Without_Drop -- - ------------------------------ - - procedure Lemma_Shift_Without_Drop - (X, Y : Double_Uns; - Mask : Single_Uns; - Shift : Natural) - is - pragma Unreferenced (Mask); - - procedure Lemma_Bound - with - Pre => Shift <= Single_Size - and then X <= 2**Single_Size - * Double_Uns'(2**(Single_Size - Shift) - 1) - + Single_Uns'(2**Single_Size - 1), - Post => X <= 2**(Double_Size - Shift) - 1; - - procedure Lemma_Exp_Pos (N : Integer) - with - Pre => N in 0 .. Double_Size - 1, - Post => Double_Uns'(2**N) > 0; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Bound is null; - procedure Lemma_Exp_Pos (N : Integer) is null; - - -- Start of processing for Lemma_Shift_Without_Drop - - begin - if Shift = 0 then - pragma Assert (Big (Y) = Big_2xx (Shift) * Big (X)); - return; - end if; - - Lemma_Bound; - Lemma_Exp_Pos (Double_Size - Shift); - pragma Assert (X < 2**(Double_Size - Shift)); - pragma Assert (Big (X) < Big_2xx (Double_Size - Shift)); - pragma Assert (Y = 2**Shift * X); - Lemma_Lt_Mult (Big (X), Big_2xx (Double_Size - Shift), Big_2xx (Shift), - Big_2xx (Shift) * Big_2xx (Double_Size - Shift)); - pragma Assert (Big_2xx (Shift) * Big (X) - < Big_2xx (Shift) * Big_2xx (Double_Size - Shift)); - Lemma_Powers_Of_2 (Shift, Double_Size - Shift); - Lemma_Mult_Commutation (2**Shift, X, Y); - pragma Assert (Big (Y) = Big_2xx (Shift) * Big (X)); - end Lemma_Shift_Without_Drop; - - ------------------------------- -- Multiply_With_Ovflo_Check -- ------------------------------- @@ -1680,160 +294,16 @@ is T1, T2 : Double_Uns; - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost; - - -- Local lemmas - - procedure Prove_Both_Too_Large - with - Ghost, - Pre => Xhi /= 0 - and then Yhi /= 0 - and then Mult = - Big_2xxSingle * Big_2xxSingle * (Big (Double_Uns'(Xhi * Yhi))) - + Big_2xxSingle * (Big (Double_Uns'(Xhi * Ylo))) - + Big_2xxSingle * (Big (Double_Uns'(Xlo * Yhi))) - + (Big (Double_Uns'(Xlo * Ylo))), - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - procedure Prove_Final_Decomposition - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1))) - and then Hi (T2) = 0, - Post => Mult = Big (Lo (T2) & Lo (T1)); - - procedure Prove_Neg_Int - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big (T2) - and then ((X >= 0 and then Y < 0) or else (X < 0 and then Y >= 0)), - Post => To_Neg_Int (T2) = X * Y; - - procedure Prove_Pos_Int - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big (T2) - and then ((X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0)), - Post => In_Double_Int_Range (Big (T2)) - and then To_Pos_Int (T2) = X * Y; - - procedure Prove_Result_Too_Large - with - Ghost, - Pre => Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1))) - and then Hi (T2) /= 0, - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - procedure Prove_Too_Large - with - Ghost, - Pre => abs (Big (X) * Big (Y)) >= Big_2xxDouble, - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - -------------------------- - -- Prove_Both_Too_Large -- - -------------------------- - - procedure Prove_Both_Too_Large is - begin - pragma Assert (Mult >= - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns'(Xhi * Yhi))); - pragma Assert (Double_Uns (Xhi) * Double_Uns (Yhi) >= 1); - pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle); - Prove_Too_Large; - end Prove_Both_Too_Large; - - ------------------------------- - -- Prove_Final_Decomposition -- - ------------------------------- - - procedure Prove_Final_Decomposition is - begin - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert (Mult = Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1)))); - pragma Assert (Mult <= Big_2xxDouble_Minus_1); - Lemma_Mult_Commutation (X, Y); - pragma Assert (Mult = abs Big (X * Y)); - Lemma_Word_Commutation (Lo (T2)); - pragma Assert (Mult = Big (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1)))); - Lemma_Add_Commutation (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)), - Lo (T1)); - pragma Assert (Mult = Big (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)) + Lo (T1))); - pragma Assert (Lo (T2) & Lo (T1) = Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)) + Lo (T1)); - end Prove_Final_Decomposition; - - ------------------- - -- Prove_Neg_Int -- - ------------------- - - procedure Prove_Neg_Int is - begin - pragma Assert (X * Y <= 0); - pragma Assert (Mult = -Big (X * Y)); - end Prove_Neg_Int; - - ------------------- - -- Prove_Pos_Int -- - ------------------- - - procedure Prove_Pos_Int is - begin - pragma Assert (X * Y >= 0); - pragma Assert (Mult = Big (X * Y)); - end Prove_Pos_Int; - - ---------------------------- - -- Prove_Result_Too_Large -- - ---------------------------- - - procedure Prove_Result_Too_Large is - begin - pragma Assert (Mult >= Big_2xxSingle * Big (T2)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert (Mult >= - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2)))); - pragma Assert (Double_Uns (Hi (T2)) >= 1); - pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle); - Prove_Too_Large; - end Prove_Result_Too_Large; - - --------------------- - -- Prove_Too_Large -- - --------------------- - - procedure Prove_Too_Large is null; - - -- Start of processing for Multiply_With_Ovflo_Check - begin - Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo); - if Xhi /= 0 then if Yhi /= 0 then - Prove_Both_Too_Large; Raise_Error; else T2 := Xhi * Ylo; - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); end if; elsif Yhi /= 0 then T2 := Xlo * Yhi; - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); else -- Yhi = Xhi = 0 T2 := 0; @@ -1843,57 +313,27 @@ is -- result from the upper halves of the input values. T1 := Xlo * Ylo; - - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); - Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns'(Xhi * Ylo)), - Big (Double_Uns'(Xlo * Yhi))); - pragma Assert (Mult = Big_2xxSingle * Big (T2) + Big (T1)); - Lemma_Add_Commutation (T2, Hi (T1)); - pragma Assert - (Big (T2 + Hi (T1)) = Big (T2) + Big (Double_Uns (Hi (T1)))); - T2 := T2 + Hi (T1); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1)))); - if Hi (T2) /= 0 then - Prove_Result_Too_Large; Raise_Error; end if; - Prove_Final_Decomposition; - T2 := Lo (T2) & Lo (T1); - pragma Assert (Mult = Big (T2)); - if X >= 0 then if Y >= 0 then - Prove_Pos_Int; return To_Pos_Int (T2); - pragma Annotate (CodePeer, Intentional, "precondition", - "Intentional Unsigned->Signed conversion"); else - Prove_Neg_Int; - Lemma_Abs_Range (Big (X) * Big (Y)); return To_Neg_Int (T2); end if; else -- X < 0 if Y < 0 then - Prove_Pos_Int; return To_Pos_Int (T2); - pragma Annotate (CodePeer, Intentional, "precondition", - "Intentional Unsigned->Signed conversion"); else - Prove_Neg_Int; - Lemma_Abs_Range (Big (X) * Big (Y)); return To_Neg_Int (T2); end if; end if; - end Multiply_With_Ovflo_Check; ----------------- @@ -1909,8 +349,6 @@ is -- Scaled_Divide -- ------------------- - pragma Annotate (Gnatcheck, Exempt_On, "Metrics_Cyclomatic_Complexity", - "limit exceeded due to proof code"); procedure Scaled_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; @@ -1928,10 +366,10 @@ is Zhi : Single_Uns := Hi (Zu); Zlo : Single_Uns := Lo (Zu); - D : array (1 .. 4) of Single_Uns with Relaxed_Initialization; + D : array (1 .. 4) of Single_Uns; -- The dividend, four digits (D(1) is high order) - Qd : array (1 .. 2) of Single_Uns with Relaxed_Initialization; + Qd : array (1 .. 2) of Single_Uns; -- The quotient digits, two digits (Qd(1) is high order) S1, S2, S3 : Single_Uns; @@ -1956,605 +394,6 @@ is T1, T2, T3 : Double_Uns; -- Temporary values - -- Local ghost variables - - Mult : constant Big_Natural := abs (Big (X) * Big (Y)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - Inter : Natural with Ghost; - - -- Local ghost functions - - function Is_Mult_Decomposition - (D1, D2, D3, D4 : Big_Integer) - return Boolean - is - (Mult = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * D1 - + Big_2xxSingle * Big_2xxSingle * D2 - + Big_2xxSingle * D3 - + D4) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function Is_Scaled_Mult_Decomposition - (D1, D2, D3, D4 : Big_Integer) - return Boolean - is - (Mult * Big_2xx (Scale) - = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * D1 - + Big_2xxSingle * Big_2xxSingle * D2 - + Big_2xxSingle * D3 - + D4) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof), - Pre => Scale < Double_Size; - - -- Local lemmas - - procedure Prove_Dividend_Scaling - with - Ghost, - Pre => D'Initialized - and then Scale <= Single_Size - and then Is_Mult_Decomposition (Big (Double_Uns (D (1))), - Big (Double_Uns (D (2))), - Big (Double_Uns (D (3))), - Big (Double_Uns (D (4)))) - and then Big (D (1) & D (2)) * Big_2xx (Scale) < Big_2xxDouble - and then T1 = Shift_Left (D (1) & D (2), Scale) - and then T2 = Shift_Left (Double_Uns (D (3)), Scale) - and then T3 = Shift_Left (Double_Uns (D (4)), Scale), - Post => Is_Scaled_Mult_Decomposition - (Big (Double_Uns (Hi (T1))), - Big (Double_Uns (Lo (T1) or Hi (T2))), - Big (Double_Uns (Lo (T2) or Hi (T3))), - Big (Double_Uns (Lo (T3)))); - -- Proves the scaling of the 4-digit dividend actually multiplies it by - -- 2**Scale. - - procedure Prove_Multiplication (Q : Single_Uns) - with - Ghost, - Pre => T1 = Q * Lo (Zu) - and then T2 = Q * Hi (Zu) - and then S3 = Lo (T1) - and then T3 = Hi (T1) + Lo (T2) - and then S2 = Lo (T3) - and then S1 = Hi (T3) + Hi (T2), - Post => Big3 (S1, S2, S3) = Big (Double_Uns (Q)) * Big (Zu); - -- Proves correctness of the multiplication of divisor by quotient to - -- compute amount to subtract. - - procedure Prove_Mult_Decomposition_Split2 - (D1, D2, D2_Hi, D2_Lo, D3, D4 : Big_Integer) - with - Ghost, - Pre => Is_Mult_Decomposition (D1, D2, D3, D4) - and then D2 = Big_2xxSingle * D2_Hi + D2_Lo, - Post => Is_Mult_Decomposition (D1 + D2_Hi, D2_Lo, D3, D4); - -- Proves decomposition of Mult after splitting second component - - procedure Prove_Mult_Decomposition_Split3 - (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) - with - Ghost, - Pre => Is_Mult_Decomposition (D1, D2, D3, D4) - and then D3 = Big_2xxSingle * D3_Hi + D3_Lo, - Post => Is_Mult_Decomposition (D1, D2 + D3_Hi, D3_Lo, D4); - -- Proves decomposition of Mult after splitting third component - - procedure Prove_Negative_Dividend - with - Ghost, - Pre => Z /= 0 - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then Big (Ru) = abs Big_R - and then ((X >= 0 and Y < 0) or (X < 0 and Y >= 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => - (if Z > 0 then Big_Q <= Big_0 - and then In_Double_Int_Range (-Big (Qu)) - else Big_Q >= Big_0 - and then In_Double_Int_Range (Big (Qu))) - and then In_Double_Int_Range (-Big (Ru)); - -- Proves the sign of rounded quotient when dividend is non-positive - - procedure Prove_Overflow - with - Ghost, - Pre => Z /= 0 - and then Mult >= Big_2xxDouble * Big (Double_Uns'(abs Z)), - Post => not In_Double_Int_Range (Big (X) * Big (Y) / Big (Z)) - and then not In_Double_Int_Range - (Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z))); - -- Proves overflow case when the quotient has at least 3 digits - - procedure Prove_Positive_Dividend - with - Ghost, - Pre => Z /= 0 - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then Big (Ru) = abs Big_R - and then ((X >= 0 and Y >= 0) or (X < 0 and Y < 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => - (if Z > 0 then Big_Q >= Big_0 - and then In_Double_Int_Range (Big (Qu)) - else Big_Q <= Big_0 - and then In_Double_Int_Range (-Big (Qu))) - and then In_Double_Int_Range (Big (Ru)); - -- Proves the sign of rounded quotient when dividend is non-negative - - procedure Prove_Qd_Calculation_Part_1 (J : Integer) - with - Ghost, - Pre => J in 1 .. 2 - and then D'Initialized - and then D (J) < Zhi - and then Hi (Zu) = Zhi - and then Qd (J)'Initialized - and then Qd (J) = Lo ((D (J) & D (J + 1)) / Zhi), - Post => Big (Double_Uns (Qd (J))) >= - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu); - -- When dividing 3 digits by 2 digits, proves the initial calculation - -- of the quotient given by dividing the first 2 digits of the dividend - -- by the first digit of the divisor is not an underestimate (so - -- readjusting down works). - - procedure Prove_Q_Too_Big - with - Ghost, - Pre => In_Double_Int_Range (Big_Q) - and then abs Big_Q = Big_2xxDouble, - Post => False; - -- Proves the inconsistency when Q is equal to Big_2xx64 - - procedure Prove_Rescaling - with - Ghost, - Pre => Scale <= Single_Size - and then Z /= 0 - and then Mult * Big_2xx (Scale) = Big (Zu) * Big (Qu) + Big (Ru) - and then Big (Ru) < Big (Zu) - and then Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale) - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => abs Quot = Big (Qu) - and then abs Big_R = Big (Shift_Right (Ru, Scale)); - -- Proves scaling back only the remainder is the right thing to do after - -- computing the scaled division. - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Zu) = Big (Double_Uns'(abs Z)), - Post => abs Big_Q = - (if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Scaled_Mult_Decomposition_Regroup24 - (D1, D2, D3, D4 : Big_Integer) - with - Ghost, - Pre => Scale < Double_Size - and then Is_Scaled_Mult_Decomposition (D1, D2, D3, D4), - Post => Is_Scaled_Mult_Decomposition - (0, Big_2xxSingle * D1 + D2, 0, Big_2xxSingle * D3 + D4); - -- Proves scaled decomposition of Mult after regrouping on second and - -- fourth component. - - procedure Prove_Scaled_Mult_Decomposition_Regroup3 - (D1, D2, D3, D4 : Single_Uns) - with - Ghost, - Pre => Scale < Double_Size - and then Is_Scaled_Mult_Decomposition - (Big (Double_Uns (D1)), Big (Double_Uns (D2)), - Big (Double_Uns (D3)), Big (Double_Uns (D4))), - Post => Is_Scaled_Mult_Decomposition (0, 0, Big3 (D1, D2, D3), - Big (Double_Uns (D4))); - -- Proves scaled decomposition of Mult after regrouping on third - -- component. - - procedure Prove_Sign_R - with - Ghost, - Pre => Z /= 0 and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => In_Double_Int_Range (Big_R); - - procedure Prove_Signs - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - (if Round then - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then In_Double_Int_Range (Big_R) - and then R = - (if (X >= 0) = (Y >= 0) then To_Pos_Int (Ru) else To_Neg_Int (Ru)) - and then Q = - (if ((X >= 0) = (Y >= 0)) = (Z >= 0) then To_Pos_Int (Qu) - else To_Neg_Int (Qu)), -- need to ensure To_Pos_Int precondition - Post => Big (R) = Big_R and then Big (Q) = Big_Q; - -- Proves final signs match the intended result after the unsigned - -- division is done. - - procedure Prove_Z_Low - with - Ghost, - Pre => Z /= 0 - and then D'Initialized - and then Hi (abs Z) = 0 - and then Lo (abs Z) = Zlo - and then Mult = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))) - and then D (2) < Zlo - and then Quot = (Big (X) * Big (Y)) / Big (Z) - and then Big_R = (Big (X) * Big (Y)) rem Big (Z) - and then T1 = D (2) & D (3) - and then T2 = Lo (T1 rem Zlo) & D (4) - and then Qu = Lo (T1 / Zlo) & Lo (T2 / Zlo) - and then Ru = T2 rem Zlo, - Post => Big (Qu) = abs Quot - and then Big (Ru) = abs Big_R; - -- Proves the case where the divisor is only one digit - - ---------------------------- - -- Prove_Dividend_Scaling -- - ---------------------------- - - procedure Prove_Dividend_Scaling is - Big_D12 : constant Big_Integer := - Big_2xx (Scale) * Big (D (1) & D (2)); - Big_T1 : constant Big_Integer := Big (T1); - Big_D3 : constant Big_Integer := - Big_2xx (Scale) * Big (Double_Uns (D (3))); - Big_T2 : constant Big_Integer := Big (T2); - Big_D4 : constant Big_Integer := - Big_2xx (Scale) * Big (Double_Uns (D (4))); - Big_T3 : constant Big_Integer := Big (T3); - - begin - Lemma_Shift_Left (D (1) & D (2), Scale); - Lemma_Ge_Mult (Big_2xxSingle, Big_2xx (Scale), Big_2xxSingle, - Big_2xxSingle * Big_2xx (Scale)); - Lemma_Lt_Mult (Big (Double_Uns (D (3))), Big_2xxSingle, - Big_2xx (Scale), Big_2xxDouble); - Lemma_Shift_Left (Double_Uns (D (3)), Scale); - Lemma_Lt_Mult (Big (Double_Uns (D (4))), Big_2xxSingle, - Big_2xx (Scale), Big_2xxDouble); - Lemma_Shift_Left (Double_Uns (D (4)), Scale); - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - pragma Assert (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big_2xxSingle * Big_D12 - + Big_2xxSingle * Big_D3 - + Big_D4); - pragma Assert (Big_2xx (Scale) > 0); - declare - Two_xx_Scale : constant Double_Uns := Double_Uns'(2 ** Scale); - D12 : constant Double_Uns := D (1) & D (2); - begin - pragma Assert (Big_2xx (Scale) * Big (D12) < Big_2xxDouble); - pragma Assert (Big (Two_xx_Scale) * Big (D12) < Big_2xxDouble); - Lemma_Mult_Commutation (Two_xx_Scale, D12, T1); - end; - pragma Assert (Big_D12 = Big_T1); - pragma Assert (Big_2xxSingle * Big_2xxSingle * Big_D12 - = Big_2xxSingle * Big_2xxSingle * Big_T1); - Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (3)), T2); - pragma Assert (Big_D3 = Big_T2); - pragma Assert (Big_2xxSingle * Big_D3 = Big_2xxSingle * Big_T2); - Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (4)), T3); - pragma Assert - (Is_Scaled_Mult_Decomposition (0, Big_T1, Big_T2, Big_T3)); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Hi_Lo (T3, Hi (T3), Lo (T3)); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (Hi (T1))), - Big (Double_Uns (Lo (T1)))); - Lemma_Mult_Distribution (Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (Hi (T2))), - Big (Double_Uns (Lo (T2)))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Lo (T1))), - Big (Double_Uns (Hi (T2)))); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (Lo (T2))), - Big (Double_Uns (Hi (T3)))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Lo (T1))), - Big (Double_Uns (Hi (T2)))); - pragma Assert (Double_Uns (Lo (T1) or Hi (T2)) = - Double_Uns (Lo (T1)) + Double_Uns (Hi (T2))); - pragma Assert (Double_Uns (Lo (T2) or Hi (T3)) = - Double_Uns (Lo (T2)) + Double_Uns (Hi (T3))); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), Hi (T2)); - Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T3)); - end Prove_Dividend_Scaling; - - -------------------------- - -- Prove_Multiplication -- - -------------------------- - - procedure Prove_Multiplication (Q : Single_Uns) is - begin - Lemma_Hi_Lo (Zu, Hi (Zu), Lo (Zu)); - Lemma_Hi_Lo (T1, Hi (T1), S3); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Hi_Lo (T3, Hi (T3), S2); - Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Lo (Zu)), T1); - Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Hi (Zu)), T2); - Lemma_Mult_Distribution (Big (Double_Uns (Q)), - Big_2xxSingle * Big (Double_Uns (Hi (Zu))), - Big (Double_Uns (Lo (Zu)))); - Lemma_Substitution - (Big (Double_Uns (Q)) * Big (Zu), - Big (Double_Uns (Q)), - Big (Zu), - Big_2xxSingle * Big (Double_Uns (Hi (Zu))) - + Big (Double_Uns (Lo (Zu))), - Big_0); - pragma Assert (Big (Double_Uns (Q)) * Big (Zu) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big (Double_Uns (S3))); - Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T1)); - pragma Assert - (By (Big (Double_Uns (Q)) * Big (Zu) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (T3) - + Big (Double_Uns (S3)), - By (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big_2xxSingle * Big (Double_Uns (Hi (T1))) - = Big_2xxSingle * Big (T3), - Double_Uns (Lo (T2)) - + Double_Uns (Hi (T1)) = T3))); - pragma Assert (Double_Uns (Hi (T3)) + Hi (T2) = Double_Uns (S1)); - Lemma_Add_Commutation (Double_Uns (Hi (T3)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T3))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (S1))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Hi (T3))), - Big (Double_Uns (Hi (T2)))); - end Prove_Multiplication; - - ------------------------------------- - -- Prove_Mult_Decomposition_Split2 -- - ------------------------------------- - - procedure Prove_Mult_Decomposition_Split2 - (D1, D2, D2_Hi, D2_Lo, D3, D4 : Big_Integer) - is null; - - ------------------------------------- - -- Prove_Mult_Decomposition_Split3 -- - ------------------------------------- - - procedure Prove_Mult_Decomposition_Split3 - (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) - is null; - - ----------------------------- - -- Prove_Negative_Dividend -- - ----------------------------- - - procedure Prove_Negative_Dividend is - begin - Lemma_Mult_Non_Positive (Big (X), Big (Y)); - end Prove_Negative_Dividend; - - -------------------- - -- Prove_Overflow -- - -------------------- - - procedure Prove_Overflow is - begin - Lemma_Div_Ge (Mult, Big_2xxDouble, Big (Double_Uns'(abs Z))); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Overflow; - - ----------------------------- - -- Prove_Positive_Dividend -- - ----------------------------- - - procedure Prove_Positive_Dividend is - begin - Lemma_Mult_Non_Negative (Big (X), Big (Y)); - end Prove_Positive_Dividend; - - --------------------------------- - -- Prove_Qd_Calculation_Part_1 -- - --------------------------------- - - procedure Prove_Qd_Calculation_Part_1 (J : Integer) is - begin - Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); - Lemma_Lt_Commutation (Double_Uns (D (J)), Double_Uns (Zhi)); - Lemma_Gt_Mult (Big (Double_Uns (Zhi)), - Big (Double_Uns (D (J))) + 1, - Big_2xxSingle, Big (D (J) & D (J + 1))); - Lemma_Div_Lt - (Big (D (J) & D (J + 1)), Big_2xxSingle, Big (Double_Uns (Zhi))); - Lemma_Div_Commutation (D (J) & D (J + 1), Double_Uns (Zhi)); - Lemma_Lo_Is_Ident ((D (J) & D (J + 1)) / Zhi); - Lemma_Div_Definition (D (J) & D (J + 1), Zhi, Double_Uns (Qd (J)), - (D (J) & D (J + 1)) rem Zhi); - Lemma_Lt_Commutation - ((D (J) & D (J + 1)) rem Zhi, Double_Uns (Zhi)); - Lemma_Gt_Mult - ((Big (Double_Uns (Qd (J))) + 1) * Big (Double_Uns (Zhi)), - Big (D (J) & D (J + 1)) + 1, Big_2xxSingle, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Hi_Lo (Zu, Zhi, Lo (Zu)); - Lemma_Gt_Mult (Big (Zu), Big_2xxSingle * Big (Double_Uns (Zhi)), - Big (Double_Uns (Qd (J))) + 1, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Div_Lt (Big3 (D (J), D (J + 1), D (J + 2)), - Big (Double_Uns (Qd (J))) + 1, Big (Zu)); - end Prove_Qd_Calculation_Part_1; - - --------------------- - -- Prove_Q_Too_Big -- - --------------------- - - procedure Prove_Q_Too_Big is - begin - pragma Assert (Big_Q = Big_2xxDouble or Big_Q = -Big_2xxDouble); - Lemma_Not_In_Range_Big2xx64; - end Prove_Q_Too_Big; - - --------------------- - -- Prove_Rescaling -- - --------------------- - - procedure Prove_Rescaling is - begin - Lemma_Div_Lt (Big (Ru), Big (Double_Uns'(abs Z)), Big_2xx (Scale)); - Lemma_Div_Eq (Mult, Big (Double_Uns'(abs Z)) * Big (Qu), - Big_2xx (Scale), Big (Ru)); - Lemma_Rev_Div_Definition (Mult, Big (Double_Uns'(abs Z)), - Big (Qu), Big (Ru) / Big_2xx (Scale)); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Commutation (Z); - Lemma_Shift_Right (Ru, Scale); - end Prove_Rescaling; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X) * Big (Y), Big (Z)) then - pragma Assert - (abs Big_Q = - (if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot)); - end if; - end Prove_Rounding_Case; - - ----------------------------------------------- - -- Prove_Scaled_Mult_Decomposition_Regroup24 -- - ----------------------------------------------- - - procedure Prove_Scaled_Mult_Decomposition_Regroup24 - (D1, D2, D3, D4 : Big_Integer) - is null; - - ---------------------------------------------- - -- Prove_Scaled_Mult_Decomposition_Regroup3 -- - ---------------------------------------------- - - procedure Prove_Scaled_Mult_Decomposition_Regroup3 - (D1, D2, D3, D4 : Single_Uns) - is null; - - ------------------ - -- Prove_Sign_R -- - ------------------ - - procedure Prove_Sign_R is - begin - pragma Assert (In_Double_Int_Range (Big (Z))); - end Prove_Sign_R; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is null; - - ----------------- - -- Prove_Z_Low -- - ----------------- - - procedure Prove_Z_Low is - begin - Lemma_Hi_Lo (T1, D (2), D (3)); - Lemma_Add_Commutation (Double_Uns (D (2)), 1); - pragma Assert - (Big (Double_Uns (D (2))) + 1 <= Big (Double_Uns (Zlo))); - Lemma_Div_Definition (T1, Zlo, T1 / Zlo, T1 rem Zlo); - pragma Assert - (By (Lo (T1 rem Zlo) = Hi (T2), - By (Double_Uns (Lo (T1 rem Zlo)) = T1 rem Zlo, - T1 rem Zlo <= Double_Uns (Zlo)))); - Lemma_Hi_Lo (T2, Lo (T1 rem Zlo), D (4)); - pragma Assert (T1 rem Zlo < Double_Uns (Zlo)); - pragma Assert (T1 rem Zlo + Double_Uns'(1) <= Double_Uns (Zlo)); - Lemma_Ge_Commutation (Double_Uns (Zlo), T1 rem Zlo + Double_Uns'(1)); - Lemma_Add_Commutation (T1 rem Zlo, 1); - pragma Assert (Big (T1 rem Zlo) + 1 <= Big (Double_Uns (Zlo))); - Lemma_Div_Definition (T2, Zlo, T2 / Zlo, Ru); - pragma Assert - (By (Big_2xxSingle * Big (Double_Uns (D (2))) - + Big (Double_Uns (D (3))) - < Big_2xxSingle * (Big (Double_Uns (D (2))) + 1), - Mult = Big (Double_Uns (Zlo)) * - (Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo)) + Big (Ru))); - Lemma_Div_Lt (Big (T1), Big_2xxSingle, Big (Double_Uns (Zlo))); - Lemma_Div_Commutation (T1, Double_Uns (Zlo)); - Lemma_Lo_Is_Ident (T1 / Zlo); - pragma Assert - (Big (T2) <= Big_2xxSingle * (Big (Double_Uns (Zlo)) - 1) - + Big (Double_Uns (D (4)))); - Lemma_Hi_Lo (Qu, Lo (T1 / Zlo), Lo (T2 / Zlo)); - Lemma_Div_Lt (Big (T2), Big_2xxSingle, Big (Double_Uns (Zlo))); - Lemma_Div_Commutation (T2, Double_Uns (Zlo)); - Lemma_Lo_Is_Ident (T2 / Zlo); - Lemma_Substitution (Mult, Big (Double_Uns (Zlo)), - Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo), - Big (Qu), Big (Ru)); - pragma Assert - (By (Ru < Double_Uns (Zlo), Ru = T2 rem Zlo)); - Lemma_Lt_Commutation (Ru, Double_Uns (Zlo)); - Lemma_Rev_Div_Definition - (Mult, Big (Double_Uns (Zlo)), Big (Qu), Big (Ru)); - pragma Assert (Double_Uns (Zlo) = abs Z); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Z_Low; - -- Start of processing for Scaled_Divide begin @@ -2562,237 +401,56 @@ is Raise_Error; end if; - Quot := Big (X) * Big (Y) / Big (Z); - Big_R := Big (X) * Big (Y) rem Big (Z); - if Round then - Big_Q := Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - -- First do the multiplication, giving the four digit dividend - Lemma_Abs_Mult_Commutation (Big (X), Big (Y)); - Lemma_Abs_Commutation (X); - Lemma_Abs_Commutation (Y); - Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo); - T1 := Xlo * Ylo; D (4) := Lo (T1); D (3) := Hi (T1); - Lemma_Hi_Lo (T1, D (3), D (4)); - if Yhi /= 0 then T1 := Xlo * Yhi; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (D (3))), - Big (Double_Uns (Lo (T1)))); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - D (3) := Lo (T2); D (2) := Hi (T1) + Hi (T2); - pragma Assert (Double_Uns (Hi (T1)) + Hi (T2) = Double_Uns (D (2))); - Lemma_Add_Commutation (Double_Uns (Hi (T1)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (D (2)))); - if Xhi /= 0 then T1 := Xhi * Ylo; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (D (3)), Lo (T1)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Prove_Mult_Decomposition_Split3 - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) - + Big (Double_Uns (Hi (T1))), - D3 => Big (T2), - D3_Hi => Big (Double_Uns (Hi (T2))), - D3_Lo => Big (Double_Uns (Lo (T2))), - D4 => Big (Double_Uns (D (4)))); - D (3) := Lo (T2); T3 := D (2) + Hi (T1); - Lemma_Add_Commutation (Double_Uns (D (2)), Hi (T1)); - Lemma_Add_Commutation (T3, Hi (T2)); - T3 := T3 + Hi (T2); T2 := Double_Uns'(Xhi * Yhi); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert - (Is_Mult_Decomposition - (D1 => Big (Double_Uns (Hi (T2))), - D2 => Big (T3) + Big (Double_Uns (Lo (T2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - T1 := T3 + Lo (T2); D (2) := Lo (T1); - - Lemma_Add_Commutation (T3, Lo (T2)); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Prove_Mult_Decomposition_Split2 - (D1 => Big (Double_Uns (Hi (T2))), - D2 => Big (T1), - D2_Lo => Big (Double_Uns (Lo (T1))), - D2_Hi => Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))); - D (1) := Hi (T2) + Hi (T1); - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); else - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))) - + Big (Double_Uns (Xhi)) * Big (Yu), - D4 => Big (Double_Uns (D (4))))); - D (1) := 0; - - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; - else if Xhi /= 0 then T1 := Xhi * Ylo; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (Hi (T1))), - D3 => Big (T2), - D4 => Big (Double_Uns (D (4))))); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - D (3) := Lo (T2); D (2) := Hi (T1) + Hi (T2); - pragma Assert - (Double_Uns (Hi (T1)) + Hi (T2) = Double_Uns (D (2))); - Lemma_Add_Commutation (Double_Uns (Hi (T1)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (D (2)))); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); else D (2) := 0; - - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; D (1) := 0; - - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; - pragma Assert_And_Cut - -- Restate the precondition - (Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - -- Restate the value of local variables - and then Zu = abs Z - and then Zhi = Hi (Zu) - and then Zlo = Lo (Zu) - and then Mult = abs (Big (X) * Big (Y)) - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big_Q = Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else - Big_Q = Quot) - -- Summarize first part of the procedure - and then D'Initialized - and then Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - -- Now it is time for the dreaded multiple precision division. First an -- easy case, check for the simple case of a one digit divisor. if Zhi = 0 then if D (1) /= 0 or else D (2) >= Zlo then - if D (1) > 0 then - Lemma_Double_Big_2xxSingle; - Lemma_Mult_Positive (Big_2xxDouble, Big_2xxSingle); - Lemma_Ge_Mult (Big (Double_Uns (D (1))), - 1, - Big_2xxDouble * Big_2xxSingle, - Big_2xxDouble * Big_2xxSingle); - Lemma_Mult_Positive (Big_2xxSingle, Big (Double_Uns (D (1)))); - Lemma_Ge_Mult (Big_2xxSingle * Big_2xxSingle, Big_2xxDouble, - Big_2xxSingle * Big (Double_Uns (D (1))), - Big_2xxDouble * Big_2xxSingle); - pragma Assert (Mult >= Big_2xxDouble * Big_2xxSingle); - Lemma_Ge_Commutation (2 ** Single_Size, Zu); - Lemma_Ge_Mult (Big_2xxSingle, Big (Zu), Big_2xxDouble, - Big_2xxDouble * Big (Zu)); - pragma Assert (Mult >= Big_2xxDouble * Big (Zu)); - else - Lemma_Ge_Commutation (Double_Uns (D (2)), Zu); - pragma Assert (Mult >= Big_2xxDouble * Big (Zu)); - end if; - - Prove_Overflow; Raise_Error; -- Here we are dividing at most three digits by one digit @@ -2803,18 +461,11 @@ is Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo); Ru := T2 rem Zlo; - - Prove_Z_Low; end if; -- If divisor is double digit and dividend is too large, raise error elsif (D (1) & D (2)) >= Zu then - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - Lemma_Ge_Commutation (D (1) & D (2), Zu); - pragma Assert - (Mult >= Big_2xxSingle * Big_2xxSingle * Big (D (1) & D (2))); - Prove_Overflow; Raise_Error; -- This is the complex case where we definitely have a double digit @@ -2827,489 +478,87 @@ is -- First normalize the divisor so that it has the leading bit on. -- We do this by finding the appropriate left shift amount. - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - Lemma_Lt_Commutation (D (1) & D (2), Zu); - pragma Assert - (Mult < Big_2xxDouble * Big (Zu)); - Shift := Single_Size; Mask := Single_Uns'Last; Scale := 0; - Inter := 0; - pragma Assert (Big_2xx (Scale) = 1); - while Shift > 1 loop - pragma Loop_Invariant (Scale <= Single_Size - Shift); - pragma Loop_Invariant ((Hi (Zu) and Mask) /= 0); - pragma Loop_Invariant - (Mask = Shift_Left (Single_Uns'Last, Single_Size - Shift)); - pragma Loop_Invariant (Zu = Shift_Left (abs Z, Scale)); - pragma Loop_Invariant (Big (Zu) = - Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - pragma Loop_Invariant (Inter in 0 .. Log_Single_Size - 1); - pragma Loop_Invariant (Shift = 2 ** (Log_Single_Size - Inter)); - pragma Loop_Invariant (Shift mod 2 = 0); - - declare - -- Local ghost variables - - Shift_Prev : constant Natural := Shift with Ghost; - Mask_Prev : constant Single_Uns := Mask with Ghost; - Zu_Prev : constant Double_Uns := Zu with Ghost; - - -- Local lemmas - - procedure Prove_Power - with - Ghost, - Pre => Inter in 0 .. Log_Single_Size - 1 - and then Shift = 2 ** (Log_Single_Size - Inter), - Post => Shift / 2 = 2 ** (Log_Single_Size - (Inter + 1)) - and then (Shift = 2 or (Shift / 2) mod 2 = 0); - - procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) - with - Ghost, - Pre => Prev /= 0 - and then (Prev and Mask) = 0, - Post => (Prev and not Mask) /= 0; - - procedure Prove_Shift_Progress - with - Ghost, - Pre => Shift <= Single_Size / 2 - and then Shift_Prev = 2 * Shift - and then Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - Shift_Prev) - and then Mask = - Shift_Left (Single_Uns'Last, - Single_Size - Shift_Prev + Shift), - Post => Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - 2 * Shift) - and then Mask = - Shift_Left (Single_Uns'Last, Single_Size - Shift); - - procedure Prove_Shifting - with - Ghost, - Pre => Shift <= Single_Size / 2 - and then Zu = Shift_Left (Zu_Prev, Shift) - and then Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - 2 * Shift) - and then Mask = - Shift_Left (Single_Uns'Last, Single_Size - Shift) - and then (Hi (Zu_Prev) and Mask_Prev and not Mask) /= 0, - Post => (Hi (Zu) and Mask) /= 0; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) is null; - procedure Prove_Power is null; - procedure Prove_Shifting is null; - procedure Prove_Shift_Progress is null; - - begin - pragma Assert (Mask = Shift_Left (Single_Uns'Last, - Single_Size - Shift_Prev)); - Prove_Power; - - Shift := Shift / 2; - - Inter := Inter + 1; - pragma Assert (Shift_Prev = 2 * Shift); - - Mask := Shift_Left (Mask, Shift); - - Lemma_Double_Shift - (Single_Uns'Last, Single_Size - Shift_Prev, Shift); - Prove_Shift_Progress; - - if (Hi (Zu) and Mask) = 0 then - Zu := Shift_Left (Zu, Shift); - - pragma Assert ((Hi (Zu_Prev) and Mask_Prev) /= 0); - pragma Assert - (By ((Hi (Zu_Prev) and Mask_Prev and Mask) = 0, - (Hi (Zu_Prev) and Mask) = 0 - and then - (Hi (Zu_Prev) and Mask_Prev and Mask) - = (Hi (Zu_Prev) and Mask and Mask_Prev) - )); - Prove_Prev_And_Mask (Hi (Zu_Prev) and Mask_Prev, Mask); - Prove_Shifting; - pragma Assert (Big (Zu_Prev) = - Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - Lemma_Shift_Without_Drop (Zu_Prev, Zu, Mask, Shift); - Lemma_Substitution - (Big (Zu), Big_2xx (Shift), - Big (Zu_Prev), Big (Double_Uns'(abs Z)) * Big_2xx (Scale), - 0); - Lemma_Powers_Of_2 (Shift, Scale); - Lemma_Substitution - (Big (Zu), Big (Double_Uns'(abs Z)), - Big_2xx (Shift) * Big_2xx (Scale), - Big_2xx (Shift + Scale), 0); - Lemma_Double_Shift (abs Z, Scale, Shift); - - Scale := Scale + Shift; - - pragma Assert (Zu = Shift_Left (abs Z, Scale)); - pragma Assert - (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - end if; - - pragma Assert - (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - end; + Shift := Shift / 2; + Mask := Shift_Left (Mask, Shift); + + if (Hi (Zu) and Mask) = 0 then + Zu := Shift_Left (Zu, Shift); + Scale := Scale + Shift; + end if; end loop; - pragma Assert_And_Cut - (Scale <= Single_Size - 1 - and then (Hi (Zu) and Mask) /= 0 - and then Mask = Shift_Left (Single_Uns'Last, Single_Size - 1) - and then Zu = Shift_Left (abs Z, Scale) - and then Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale) - and then Mult < Big_2xxDouble * Big (Double_Uns'(abs Z))); Zhi := Hi (Zu); Zlo := Lo (Zu); - pragma Assert ((Zhi and Mask) /= 0); - pragma Assert (Zhi >= 2 ** (Single_Size - 1)); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - -- We have Hi (Zu) /= 0 before normalization. The sequence of - -- Shift_Left operations results in the leading bit of Zu being 1 by - -- moving the leftmost 1-bit in Zu to leading position, thus - -- Zhi = Hi (Zu) >= 2 ** (Single_Size - 1) here. - -- Note that when we scale up the dividend, it still fits in four -- digits, since we already tested for overflow, and scaling does -- not change the invariant that (D (1) & D (2)) < Zu. - Lemma_Lt_Commutation (D (1) & D (2), abs Z); - Lemma_Big_Of_Double_Uns (Zu); - Lemma_Lt_Mult (Big (D (1) & D (2)), - Big (Double_Uns'(abs Z)), Big_2xx (Scale), - Big_2xxDouble); - T1 := Shift_Left (D (1) & D (2), Scale); T2 := Shift_Left (Double_Uns (D (3)), Scale); T3 := Shift_Left (Double_Uns (D (4)), Scale); - Prove_Dividend_Scaling; - D (1) := Hi (T1); D (2) := Lo (T1) or Hi (T2); D (3) := Lo (T2) or Hi (T3); D (4) := Lo (T3); - pragma Assert (D (1) = Hi (T1) and D (2) = (Lo (T1) or Hi (T2)) - and D (3) = (Lo (T2) or Hi (T3)) and D (4) = Lo (T3)); - Lemma_Substitution (Big_2xxDouble * Big (Zu), Big_2xxDouble, Big (Zu), - Big (Double_Uns'(abs Z)) * Big_2xx (Scale), 0); - pragma Assert (Mult < Big_2xxDouble * Big (Double_Uns'(abs Z))); - Lemma_Lt_Mult (Mult, Big_2xxDouble * Big (Double_Uns'(abs Z)), - Big_2xx (Scale), Big_2xxDouble * Big (Zu)); - pragma Assert (Mult >= Big_0); - pragma Assert (Big_2xx (Scale) >= Big_0); - Lemma_Mult_Non_Negative (Mult, Big_2xx (Scale)); - Lemma_Div_Lt (Mult * Big_2xx (Scale), Big (Zu), Big_2xxDouble); - Lemma_Concat_Definition (D (1), D (2)); - Lemma_Double_Big_2xxSingle; - Prove_Scaled_Mult_Decomposition_Regroup24 - (Big (Double_Uns (D (1))), - Big (Double_Uns (D (2))), - Big (Double_Uns (D (3))), - Big (Double_Uns (D (4)))); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big_2xxSingle * Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (D (1))) - + Big (Double_Uns (D (2))), - Big (D (1) & D (2)), - Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - pragma Assert - (By (Big (D (1) & D (2)) < Big (Zu), - Big_2xxDouble * (Big (Zu) - Big (D (1) & D (2))) > - Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))))); - -- Loop to compute quotient digits, runs twice for Qd (1) and Qd (2) - declare - -- Local lemmas - - procedure Prove_First_Iteration (X1, X2, X3, X4 : Single_Uns) - with - Ghost, - Pre => X1 = 0, - Post => - Big_2xxSingle * Big3 (X1, X2, X3) + Big (Double_Uns (X4)) - = Big3 (X2, X3, X4); - - --------------------------- - -- Prove_First_Iteration -- - --------------------------- - - procedure Prove_First_Iteration (X1, X2, X3, X4 : Single_Uns) is - null; - - -- Local ghost variables - - Qd1 : Single_Uns := 0 with Ghost; - D234 : Big_Integer with Ghost, Relaxed_Initialization; - D123 : constant Big_Integer := Big3 (D (1), D (2), D (3)) - with Ghost; - D4 : constant Big_Integer := Big (Double_Uns (D (4))) - with Ghost; - - begin - Prove_Scaled_Mult_Decomposition_Regroup3 - (D (1), D (2), D (3), D (4)); - pragma Assert - (By (Mult * Big_2xx (Scale) = Big_2xxSingle * D123 + D4, - Is_Scaled_Mult_Decomposition (0, 0, D123, D4))); - - for J in 1 .. 2 loop - Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); - pragma Assert (Big (D (J) & D (J + 1)) < Big (Zu)); - - -- Compute next quotient digit. We have to divide three digits - -- by two digits. We estimate the quotient by dividing the - -- leading two digits by the leading digit. Given the scaling - -- we did above which ensured the first bit of the divisor is - -- set, this gives an estimate of the quotient that is at most - -- two too high. - - if D (J) > Zhi then - Lemma_Lt_Commutation (Zu, D (J) & D (J + 1)); - pragma Assert (False); - - elsif D (J) = Zhi then - Qd (J) := Single_Uns'Last; - - Lemma_Concat_Definition (D (J), D (J + 1)); - Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 2)); - pragma Assert (Big_2xxSingle > Big (Double_Uns (D (J + 2)))); - pragma Assert - (By (Big3 (D (J), D (J + 1), 0) + Big_2xxSingle - > Big3 (D (J), D (J + 1), D (J + 2)), - Big3 (D (J), D (J + 1), 0) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1))))); - pragma Assert (Big (Double_Uns'(0)) = 0); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle = - Big_2xxSingle * (Big_2xxSingle * Big (Double_Uns (D (J))) - + Big (Double_Uns (D (J + 1))))); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1)))); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle - = Big3 (D (J), D (J + 1), 0)); - pragma Assert ((Big (D (J) & D (J + 1)) + 1) * Big_2xxSingle - = Big3 (D (J), D (J + 1), 0) + Big_2xxSingle); - Lemma_Gt_Mult (Big (Zu), Big (D (J) & D (J + 1)) + 1, - Big_2xxSingle, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Div_Lt - (Big3 (D (J), D (J + 1), D (J + 2)), - Big_2xxSingle, Big (Zu)); - pragma Assert - (By (Big (Double_Uns (Qd (J))) >= - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu), - Big (Double_Uns (Qd (J))) = Big_2xxSingle - 1)); - - else - Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi); - - Prove_Qd_Calculation_Part_1 (J); - end if; - - pragma Assert (for all K in 1 .. J => Qd (K)'Initialized); - Lemma_Div_Mult (Big3 (D (J), D (J + 1), D (J + 2)), Big (Zu)); - Lemma_Gt_Mult - (Big (Double_Uns (Qd (J))), - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu), - Big (Zu), Big3 (D (J), D (J + 1), D (J + 2)) - Big (Zu)); - - -- Compute amount to subtract - - T1 := Qd (J) * Zlo; - T2 := Qd (J) * Zhi; - S3 := Lo (T1); - T3 := Hi (T1) + Lo (T2); - S2 := Lo (T3); - S1 := Hi (T3) + Hi (T2); - - Prove_Multiplication (Qd (J)); - - -- Adjust quotient digit if it was too high - - -- We use the version of the algorithm in the 2nd Edition - -- of "The Art of Computer Programming". This had a bug not - -- discovered till 1995, see Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. - -- Under rare circumstances the expression in the test could - -- overflow. This version was further corrected in 2005, see - -- Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. - -- This implementation is not impacted by these bugs, due - -- to the use of a word-size comparison done in function Le3 - -- instead of a comparison on two-word integer quantities in - -- the original algorithm. - - Lemma_Hi_Lo_3 (Zu, Zhi, Zlo); - - while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop - pragma Loop_Invariant - (Qd (1)'Initialized - and (if J = 2 then Qd (2)'Initialized)); - pragma Loop_Invariant (if J = 2 then Qd (1) = Qd1); - pragma Loop_Invariant - (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); - pragma Loop_Invariant - (Big3 (S1, S2, S3) > Big3 (D (J), D (J + 1), D (J + 2))); - pragma Assert (Big3 (S1, S2, S3) > 0); - if Qd (J) = 0 then - pragma Assert (Big3 (S1, S2, S3) = 0); - pragma Assert (False); - end if; - Lemma_Ge_Commutation (Double_Uns (Qd (J)), 1); - Lemma_Ge_Mult - (Big (Double_Uns (Qd (J))), 1, Big (Zu), Big (Zu)); - - Sub3 (S1, S2, S3, 0, Zhi, Zlo); - - pragma Assert - (Big3 (S1, S2, S3) > - Big3 (D (J), D (J + 1), D (J + 2)) - Big (Zu)); - Lemma_Subtract_Commutation (Double_Uns (Qd (J)), 1); - pragma Assert (Double_Uns (Qd (J)) - Double_Uns'(1) - = Double_Uns (Qd (J) - 1)); - pragma Assert (Big (Double_Uns'(1)) = 1); - - declare - Prev : constant Single_Uns := Qd (J) with Ghost; - begin - Qd (J) := Qd (J) - 1; - Lemma_Substitution (Big3 (S1, S2, S3), Big (Zu), - Big (Double_Uns (Prev)) - 1, - Big (Double_Uns (Qd (J))), 0); - end; - - pragma Assert - (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); - end loop; - - pragma Assert_And_Cut - (Qd (1)'Initialized - and then (if J = 2 then Qd (2)'Initialized and Qd (1) = Qd1) - and then D'Initialized - and then (if J = 2 then D234'Initialized) - and then Big3 (D (J), D (J + 1), D (J + 2)) = - (if J = 1 then D123 else D234) - and then (if J = 1 then D4 = Big (Double_Uns (D (4)))) - and then Big3 (S1, S2, S3) = - Big (Double_Uns (Qd (J))) * Big (Zu) - and then Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) - and then Big3 (D (J), D (J + 1), D (J + 2)) - - Big3 (S1, S2, S3) < Big (Zu)); - - -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step - - Inline_Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)); - - declare - D4_G : constant Single_Uns := D (4) with Ghost; - begin - Sub3 (D (J), D (J + 1), D (J + 2), S1, S2, S3); - pragma Assert (if J = 1 then D (4) = D4_G); - pragma Assert - (By - (D'Initialized, - D (1)'Initialized and D (2)'Initialized - and D (3)'Initialized and D (4)'Initialized)); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) = - (if J = 1 then D123 else D234) - - Big3 (S1, S2, S3)); - end; - - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) < Big (Zu)); - - if D (J) > 0 then - Lemma_Double_Big_2xxSingle; - pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) = - Big_2xxSingle - * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1))) - + Big (Double_Uns (D (J + 2)))); - pragma Assert (Big_2xxSingle >= 0); - Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 1)); - pragma Assert (Big (Double_Uns (D (J + 1))) >= 0); - Lemma_Mult_Non_Negative - (Big_2xxSingle, Big (Double_Uns (D (J + 1)))); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) >= - Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (D (J)))); - Lemma_Ge_Commutation (Double_Uns (D (J)), Double_Uns'(1)); - Lemma_Ge_Mult (Big (Double_Uns (D (J))), - Big (Double_Uns'(1)), - Big_2xxDouble, - Big (Double_Uns'(1)) * Big_2xxDouble); - pragma Assert - (Big_2xxDouble * Big (Double_Uns'(1)) = Big_2xxDouble); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) >= Big_2xxDouble); - pragma Assert (False); - end if; - - if J = 1 then - Qd1 := Qd (1); - D234 := Big3 (D (2), D (3), D (4)); - pragma Assert (D4 = Big (Double_Uns (D (4)))); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big_2xxSingle, D123, - Big3 (D (1), D (2), D (3)) + Big3 (S1, S2, S3), - Big (Double_Uns (D (4)))); - Prove_First_Iteration (D (1), D (2), D (3), D (4)); - Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle, - Big3 (S1, S2, S3), - Big (Double_Uns (Qd1)) * Big (Zu), - D234); - else - pragma Assert (Qd1 = Qd (1)); - pragma Assert - (By (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big (Double_Uns (Qd (2))) * Big (Zu) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))), - By (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big3 (D (2), D (3), D (4)) + Big3 (S1, S2, S3), - Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + D234))); - - end if; + for J in 1 .. 2 loop + -- Compute next quotient digit. We have to divide three digits + -- by two digits. We estimate the quotient by dividing the + -- leading two digits by the leading digit. Given the scaling + -- we did above which ensured the first bit of the divisor is + -- set, this gives an estimate of the quotient that is at most + -- two too high. + + pragma Assert (D (J) <= Zhi); + + if D (J) = Zhi then + Qd (J) := Single_Uns'Last; + else + Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi); + end if; + + -- Compute amount to subtract + + T1 := Qd (J) * Zlo; + T2 := Qd (J) * Zhi; + S3 := Lo (T1); + T3 := Hi (T1) + Lo (T2); + S2 := Lo (T3); + S1 := Hi (T3) + Hi (T2); + + -- Adjust quotient digit if it was too high + + -- We use the version of the algorithm in the 2nd Edition + -- of "The Art of Computer Programming". This had a bug not + -- discovered till 1995, see Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. + -- Under rare circumstances the expression in the test could + -- overflow. This version was further corrected in 2005, see + -- Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. + -- This implementation is not impacted by these bugs, due + -- to the use of a word-size comparison done in function Le3 + -- instead of a comparison on two-word integer quantities in + -- the original algorithm. + + while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop + Sub3 (S1, S2, S3, 0, Zhi, Zlo); + Qd (J) := Qd (J) - 1; end loop; - pragma Assert_And_Cut - (Qd (1)'Initialized and then Qd (2)'Initialized - and then D'Initialized - and then Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))) < Big (Zu) - and then Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big (Double_Uns (Qd (2))) * Big (Zu) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - end; + -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step + + Sub3 (D (J), D (J + 1), D (J + 2), S1, S2, S3); + end loop; -- The two quotient digits are now set, and the remainder of the -- scaled division is in D3&D4. To get the remainder for the @@ -3321,271 +570,68 @@ is Qu := Qd (1) & Qd (2); Ru := D (3) & D (4); - Lemma_Hi_Lo (Qu, Qd (1), Qd (2)); - Lemma_Hi_Lo (Ru, D (3), D (4)); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big (Zu), - Big_2xxSingle * Big (Double_Uns (Qd (1))) - + Big (Double_Uns (Qd (2))), - Big (Qu), Big (Ru)); - Prove_Rescaling; - Ru := Shift_Right (Ru, Scale); - declare - -- Local lemma required to help automatic provers - procedure Lemma_Div_Congruent - (X, Y : Big_Natural; - Z : Big_Positive) - with - Ghost, - Pre => X = Y, - Post => X / Z = Y / Z; - - procedure Lemma_Div_Congruent - (X, Y : Big_Natural; - Z : Big_Positive) - is null; - - begin - Lemma_Shift_Right (Zu, Scale); - Lemma_Div_Congruent (Big (Zu), - Big (Double_Uns'(abs Z)) * Big_2xx (Scale), - Big_2xx (Scale)); - - Zu := Shift_Right (Zu, Scale); - - Lemma_Simplify (Big (Double_Uns'(abs Z)), Big_2xx (Scale)); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z))); - end; + Zu := Shift_Right (Zu, Scale); end if; - pragma Assert (Big (Ru) = abs Big_R); - pragma Assert (Big (Qu) = abs Quot); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z))); - -- Deal with rounding case if Round then - Prove_Rounding_Case; - if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) then - pragma Assert (abs Big_Q = Big (Qu) + 1); - -- Protect against wrapping around when rounding, by signaling -- an overflow when the quotient is too large. if Qu = Double_Uns'Last then - Prove_Q_Too_Big; Raise_Error; end if; - Lemma_Add_One (Qu); - Qu := Qu + Double_Uns'(1); end if; end if; - pragma Assert (Big (Qu) = abs Big_Q); - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X * Y) sign positive if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then - Prove_Positive_Dividend; - R := To_Pos_Int (Ru); Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); -- Case of dividend (X * Y) sign negative else - Prove_Negative_Dividend; - R := To_Neg_Int (Ru); Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; - - Prove_Sign_R; - Prove_Signs; end Scaled_Divide; - pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_Cyclomatic_Complexity"); ---------- -- Sub3 -- ---------- procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) is - - -- Local ghost variables - - XX1 : constant Single_Uns := X1 with Ghost; - XX2 : constant Single_Uns := X2 with Ghost; - XX3 : constant Single_Uns := X3 with Ghost; - - -- Local lemmas - - procedure Lemma_Add3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => X1 <= Single_Uns'Last - Y1 - and then X2 <= Single_Uns'Last - Y2 - and then X3 <= Single_Uns'Last - Y3, - Post => Big3 (X1 + Y1, X2 + Y2, X3 + Y3) - = Big3 (X1, X2, X3) + Big3 (Y1, Y2, Y3); - - procedure Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => Big3 (X1, X2, X3) >= Big3 (Y1, Y2, Y3), - Post => X1 > Y1 - or else (X1 = Y1 and then X2 > Y2) - or else (X1 = Y1 and then X2 = Y2 and then X3 >= Y3); - - procedure Lemma_Sub3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => X1 >= Y1 and then X2 >= Y2 and then X3 >= Y3, - Post => Big3 (X1 - Y1, X2 - Y2, X3 - Y3) - = Big3 (X1, X2, X3) - Big3 (Y1, Y2, Y3); - - procedure Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2 : Single_Uns) - with - Ghost, - Pre => X2 < Y2, - Post => Big3 (X1, X2 - Y2, X3) - = Big3 (X1, X2, X3) + Big3 (Single_Uns'(1), 0, 0) - Big3 (0, Y2, 0); - - procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) - with - Ghost, - Pre => X3 < Y3, - Post => Big3 (X1, X2, X3 - Y3) - = Big3 (X1, X2, X3) + Big3 (Single_Uns'(0), 1, 0) - Big3 (0, 0, Y3); - - ------------------------- - -- Lemma_Add3_No_Carry -- - ------------------------- - - procedure Lemma_Add3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is - begin - Lemma_Add_Commutation (Double_Uns (X1), Y1); - Lemma_Add_Commutation (Double_Uns (X2), Y2); - Lemma_Add_Commutation (Double_Uns (X3), Y3); - end Lemma_Add3_No_Carry; - - --------------------- - -- Lemma_Ge_Expand -- - --------------------- - - procedure Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is null; - - ------------------------- - -- Lemma_Sub3_No_Carry -- - ------------------------- - - procedure Lemma_Sub3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is - begin - Lemma_Subtract_Commutation (Double_Uns (X1), Double_Uns (Y1)); - Lemma_Subtract_Commutation (Double_Uns (X2), Double_Uns (Y2)); - Lemma_Subtract_Commutation (Double_Uns (X3), Double_Uns (Y3)); - end Lemma_Sub3_No_Carry; - - ---------------------------- - -- Lemma_Sub3_With_Carry2 -- - ---------------------------- - - procedure Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2 : Single_Uns) is - pragma Unreferenced (X1, X3); - begin - Lemma_Add_Commutation - (Double_Uns'(2 ** Single_Size) - Double_Uns (Y2), X2); - Lemma_Subtract_Commutation - (Double_Uns'(2 ** Single_Size), Double_Uns (Y2)); - end Lemma_Sub3_With_Carry2; - - ---------------------------- - -- Lemma_Sub3_With_Carry3 -- - ---------------------------- - - procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) is - pragma Unreferenced (X1, X2); - begin - Lemma_Add_Commutation - (Double_Uns'(2 ** Single_Size) - Double_Uns (Y3), X3); - Lemma_Subtract_Commutation - (Double_Uns'(2 ** Single_Size), Double_Uns (Y3)); - end Lemma_Sub3_With_Carry3; - - -- Start of processing for Sub3 - begin - Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3); - if Y3 > X3 then if X2 = 0 then pragma Assert (X1 >= 1); - Lemma_Sub3_No_Carry (X1, X2, X3, 1, 0, 0); X1 := X1 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = - Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(1), 0, 0)); - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (Single_Uns'(0), Single_Uns'Last, 0) - - Big3 (Single_Uns'(0), 1, 0)); - Lemma_Add3_No_Carry (X1, X2, X3, 0, Single_Uns'Last, 0); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, 1, 0); end if; X2 := X2 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = - Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(0), 1, 0)); - Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, 0, Y3); end if; X3 := X3 - Y3; - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, 0, Y3)); - if Y2 > X2 then pragma Assert (X1 >= 1); - Lemma_Sub3_No_Carry (X1, X2, X3, 1, 0, 0); X1 := X1 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, 0, Y3) - Big3 (Single_Uns'(1), 0, 0)); - Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, Y2, 0); end if; X2 := X2 - Y2; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, Y2, Y3)); - pragma Assert (X1 >= Y1); - Lemma_Sub3_No_Carry (X1, Y2, X3, Y1, 0, 0); - X1 := X1 - Y1; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, Y2, Y3) - Big3 (Y1, 0, 0)); - Lemma_Add3_No_Carry (0, Y2, Y3, Y1, 0, 0); - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (Y1, Y2, Y3)); end Sub3; ------------------------------- @@ -3594,128 +640,18 @@ is function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is R : constant Double_Int := To_Int (To_Uns (X) - To_Uns (Y)); - - -- Local lemmas - - procedure Prove_Negative_X - with - Ghost, - Pre => X < 0 and then (Y <= 0 or else R < 0), - Post => R = X - Y; - - procedure Prove_Non_Negative_X - with - Ghost, - Pre => X >= 0 and then (Y > 0 or else R >= 0), - Post => R = X - Y; - - procedure Prove_Overflow_Case - with - Ghost, - Pre => - (if X >= 0 then Y <= 0 and then R < 0 - else Y > 0 and then R >= 0), - Post => not In_Double_Int_Range (Big (X) - Big (Y)); - - ---------------------- - -- Prove_Negative_X -- - ---------------------- - - procedure Prove_Negative_X is - begin - if X = Double_Int'First then - if Y = Double_Int'First or else Y > 0 then - null; - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = - 2 ** (Double_Size - 1) + Double_Uns (-Y)); - end if; - - elsif Y >= 0 or else Y = Double_Int'First then - null; - - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = -Double_Uns (-X) + Double_Uns (-Y)); - end if; - end Prove_Negative_X; - - -------------------------- - -- Prove_Non_Negative_X -- - -------------------------- - - procedure Prove_Non_Negative_X is - begin - if Y > 0 then - declare - Ru : constant Double_Uns := To_Uns (X) - To_Uns (Y); - begin - pragma Assert (Ru = Double_Uns (X) - Double_Uns (Y)); - if Ru < 2 ** (Double_Size - 1) then -- R >= 0 - pragma Assert (To_Uns (Y) <= To_Uns (X)); - Lemma_Subtract_Double_Uns (X => Y, Y => X); - pragma Assert (Ru = Double_Uns (X - Y)); - - elsif Ru = 2 ** (Double_Size - 1) then - pragma Assert (Double_Uns (Y) < 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (R = -Double_Int (-(Double_Uns (X) - Double_Uns (Y)))); - pragma Assert - (R = -Double_Int (-Double_Uns (X) + Double_Uns (Y))); - pragma Assert - (R = -Double_Int (Double_Uns (Y) - Double_Uns (X))); - end if; - end; - - elsif Y = Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = - Double_Uns (X) - 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = Double_Uns (X) + Double_Uns (-Y)); - end if; - end Prove_Non_Negative_X; - - ------------------------- - -- Prove_Overflow_Case -- - ------------------------- - - procedure Prove_Overflow_Case is - begin - if X >= 0 and then Y /= Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = Double_Uns (X) + Double_Uns (-Y)); - - elsif X < 0 and then X /= Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = -Double_Uns (-X) - Double_Uns (Y)); - end if; - end Prove_Overflow_Case; - - -- Start of processing for Subtract_With_Ovflo_Check - begin if X >= 0 then if Y > 0 or else R >= 0 then - Prove_Non_Negative_X; return R; end if; else -- X < 0 if Y <= 0 or else R < 0 then - Prove_Negative_X; return R; end if; end if; - Prove_Overflow_Case; Raise_Error; end Subtract_With_Ovflo_Check; @@ -3752,5 +688,3 @@ is pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end System.Arith_Double; - -pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_LSLOC"); diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads index 5524cd0..f7240de 100644 --- a/gcc/ada/libgnat/s-aridou.ads +++ b/gcc/ada/libgnat/s-aridou.ads @@ -33,8 +33,6 @@ -- double word signed integer values in cases where either overflow checking -- is required, or intermediate results are longer than the result type. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic type Double_Int is range <>; @@ -55,51 +53,7 @@ generic package System.Arith_Double with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - subtype Big_Natural is BI_Ghost.Big_Natural with Ghost; - subtype Big_Positive is BI_Ghost.Big_Positive with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is - new BI_Ghost.Signed_Conversions (Int => Double_Int); - - function Big (Arg : Double_Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - package Unsigned_Conversion is - new BI_Ghost.Unsigned_Conversions (Int => Double_Uns); - - function Big (Arg : Double_Uns) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function In_Double_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Double_Int'First), Big (Double_Int'Last))) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check'Result = X + Y; + function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; -- Raises Constraint_Error if sum of operands overflows Double_Int, -- otherwise returns this sum of operands as Double_Int. -- @@ -114,10 +68,7 @@ is -- the exception *Constraint_Error* is raised; otherwise the result is -- correct. - function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check'Result = X - Y; + function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; -- Raises Constraint_Error if difference of operands overflows Double_Int, -- otherwise returns this difference of operands as Double_Int. -- @@ -127,10 +78,7 @@ is -- overflow. function Multiply_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check'Result = X * Y; - pragma Convention (C, Multiply_With_Ovflo_Check); + with Convention => C; -- Raises Constraint_Error if product of operands overflows Double_Int, -- otherwise returns this product of operands as Double_Int. The code -- generator may also generate direct calls to this routine. @@ -140,40 +88,10 @@ is -- signed value is returned. Overflow check is performed by looking at -- higher digits. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Double_Int'(0)) - or else Y = Big (Double_Int'(0)) - or else (X < Big (Double_Int'(0))) = (Y < Big (Double_Int'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Double_Int'(1))) / Big (Double_Int'(2)) then - (if Same_Sign (X, Y) then Q + Big (Double_Int'(1)) - else Q - Big (Double_Int'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- @@ -204,22 +122,7 @@ is procedure Double_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division ``X`` / (``Y`` * ``Z``), storing the quotient in -- ``Q`` and the remainder in ``R``. Constraint_Error is raised if ``Y`` or -- ``Z`` is zero, or if the quotient does not fit in ``Double_Int``. diff --git a/gcc/ada/libgnat/s-arit128.adb b/gcc/ada/libgnat/s-arit128.adb index b9fcbd9..c4ef40d 100644 --- a/gcc/ada/libgnat/s-arit128.adb +++ b/gcc/ada/libgnat/s-arit128.adb @@ -34,7 +34,6 @@ with System.Arith_Double; package body System.Arith_128 with SPARK_Mode is - subtype Uns128 is Interfaces.Unsigned_128; subtype Uns64 is Interfaces.Unsigned_64; diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads index 9181f0b..ea4ef6b 100644 --- a/gcc/ada/libgnat/s-arit128.ads +++ b/gcc/ada/libgnat/s-arit128.ads @@ -36,102 +36,31 @@ pragma Restrictions (No_Elaboration_Code); -- Allow direct call from gigi generated code --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Interfaces; package System.Arith_128 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - use type Interfaces.Integer_128; - subtype Int128 is Interfaces.Integer_128; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int128); - - function Big (Arg : Int128) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int128_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int128'First), Big (Int128'Last))) - with Ghost; - - function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check128'Result = X + Y; + function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128; -- Raises Constraint_Error if sum of operands overflows 128 bits, -- otherwise returns the 128-bit signed integer sum. - function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check128'Result = X - Y; + function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128; -- Raises Constraint_Error if difference of operands overflows 128 -- bits, otherwise returns the 128-bit signed integer difference. - function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check128'Result = X * Y; + function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128; pragma Export (C, Multiply_With_Ovflo_Check128, "__gnat_mulv128"); -- Raises Constraint_Error if product of operands overflows 128 -- bits, otherwise returns the 128-bit signed integer product. -- The code generator may also generate direct calls to this routine. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int128'(0)) - or else Y = Big (Int128'(0)) - or else (X < Big (Int128'(0))) = (Y < Big (Int128'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Int128'(1))) / Big (Int128'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int128'(1)) - else Q - Big (Int128'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide128 (X, Y, Z : Int128; Q, R : out Int128; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int128_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (X * Y) / Z, storing the quotient in Q -- and the remainder in R. Constraint_Error is raised if Z is zero, -- or if the quotient does not fit in 128 bits. Round indicates if @@ -143,22 +72,7 @@ is procedure Double_Divide128 (X, Y, Z : Int128; Q, R : out Int128; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Int128_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division X / (Y * Z), storing the quotient in Q and -- the remainder in R. Constraint_Error is raised if Y or Z is zero, -- or if the quotient does not fit in 128 bits. Round indicates if the diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb index 91082e7..0cc88ed 100644 --- a/gcc/ada/libgnat/s-arit32.adb +++ b/gcc/ada/libgnat/s-arit32.adb @@ -34,20 +34,11 @@ -- would be too costly otherwise. This is enforced by setting the assertion -- policy to Ignore. -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Ada.Unchecked_Conversion; package body System.Arith_32 with SPARK_Mode is - pragma Suppress (Overflow_Check); pragma Suppress (Range_Check); @@ -58,33 +49,6 @@ is function To_Int is new Ada.Unchecked_Conversion (Uns32, Int32); - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns32); - - function Big (Arg : Uns32) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with Ghost; - - package Unsigned_Conversion_64 is new Unsigned_Conversions (Int => Uns64); - - function Big (Arg : Uns64) return Big_Integer is - (Unsigned_Conversion_64.To_Big_Integer (Arg)) - with Ghost; - - pragma Warnings - (Off, "non-preelaborable call not allowed in preelaborated unit", - Reason => "Ghost code is not compiled"); - Big_0 : constant Big_Integer := - Big (Uns32'(0)) - with Ghost; - Big_2xx32 : constant Big_Integer := - Big (Uns32'(2 ** 32 - 1)) + 1 - with Ghost; - Big_2xx64 : constant Big_Integer := - Big (Uns64'(2 ** 64 - 1)) + 1 - with Ghost; - pragma Warnings - (On, "non-preelaborable call not allowed in preelaborated unit"); - ----------------------- -- Local Subprograms -- ----------------------- @@ -96,166 +60,23 @@ is -- Convert absolute value of X to unsigned. Note that we can't just use -- the expression of the Else since it overflows for X = Int32'First. - function Lo (A : Uns64) return Uns32 is (Uns32 (A and (2 ** 32 - 1))); - -- Low order half of 64-bit value - function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32))); -- High order half of 64-bit value - function To_Neg_Int (A : Uns32) return Int32 - with - Pre => In_Int32_Range (-Big (A)), - Post => Big (To_Neg_Int'Result) = -Big (A); + function To_Neg_Int (A : Uns32) return Int32; -- Convert to negative integer equivalent. If the input is in the range -- 0 .. 2**31, then the corresponding nonpositive signed integer (obtained -- by negating the given value) is returned, otherwise constraint error is -- raised. - function To_Pos_Int (A : Uns32) return Int32 - with - Pre => In_Int32_Range (Big (A)), - Post => Big (To_Pos_Int'Result) = Big (A); + function To_Pos_Int (A : Uns32) return Int32; -- Convert to positive integer equivalent. If the input is in the range -- 0 .. 2**31 - 1, then the corresponding nonnegative signed integer is -- returned, otherwise constraint error is raised. - procedure Raise_Error with - Always_Terminates, - Exceptional_Cases => (Constraint_Error => True); - pragma No_Return (Raise_Error); + procedure Raise_Error with No_Return; -- Raise constraint error with appropriate message - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Abs_Commutation (X : Int32) - with - Ghost, - Post => abs Big (X) = Big (Uns32'(abs X)); - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X / Y) = abs X / abs Y; - - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) - with - Ghost, - Post => abs (X * Y) = abs X * abs Y; - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X rem Y) = (abs X) rem (abs Y); - - procedure Lemma_Div_Commutation (X, Y : Uns64) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Z > 0 and then X >= Y * Z, - Post => X / Z >= Y; - - procedure Lemma_Ge_Commutation (A, B : Uns32) - with - Ghost, - Pre => A >= B, - Post => Big (A) >= Big (B); - - procedure Lemma_Hi_Lo (Xu : Uns64; Xhi, Xlo : Uns32) - with - Ghost, - Pre => Xhi = Hi (Xu) and Xlo = Lo (Xu), - Post => Big (Xu) = Big_2xx32 * Big (Xhi) + Big (Xlo); - - procedure Lemma_Mult_Commutation (X, Y, Z : Uns64) - with - Ghost, - Pre => Big (X) * Big (Y) < Big_2xx64 and then Z = X * Y, - Post => Big (X) * Big (Y) = Big (Z); - - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) - with - Ghost, - Pre => (X >= Big_0 and then Y >= Big_0) - or else (X <= Big_0 and then Y <= Big_0), - Post => X * Y >= Big_0; - - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X <= Big_0 and then Y >= Big_0) - or else (X >= Big_0 and then Y <= Big_0), - Post => X * Y <= Big_0; - - procedure Lemma_Neg_Rem (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (-Y); - - procedure Lemma_Not_In_Range_Big2xx32 - with - Post => not In_Int32_Range (Big_2xx32) - and then not In_Int32_Range (-Big_2xx32); - - procedure Lemma_Rem_Commutation (X, Y : Uns64) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) rem Big (Y) = Big (X rem Y); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Abs_Commutation (X : Int32) is null; - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Div_Commutation (X, Y : Uns64) is null; - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null; - procedure Lemma_Ge_Commutation (A, B : Uns32) is null; - procedure Lemma_Mult_Commutation (X, Y, Z : Uns64) is null; - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; - procedure Lemma_Not_In_Range_Big2xx32 is null; - procedure Lemma_Rem_Commutation (X, Y : Uns64) is null; - - ------------------------------- - -- Lemma_Abs_Rem_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - Lemma_Neg_Rem (X, Y); - if X < 0 then - pragma Assert (X rem Y = -((-X) rem (-Y))); - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - else - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - end if; - end if; - end Lemma_Abs_Rem_Commutation; - - ----------------- - -- Lemma_Hi_Lo -- - ----------------- - - procedure Lemma_Hi_Lo (Xu : Uns64; Xhi, Xlo : Uns32) is - begin - pragma Assert (Uns64 (Xhi) = Xu / Uns64'(2 ** 32)); - pragma Assert (Uns64 (Xlo) = Xu mod 2 ** 32); - end Lemma_Hi_Lo; - ----------------- -- Raise_Error -- ----------------- @@ -263,9 +84,6 @@ is procedure Raise_Error is begin raise Constraint_Error with "32-bit arithmetic overflow"; - pragma Annotate - (GNATprove, Intentional, "exception might be raised", - "Procedure Raise_Error is called to signal input errors"); end Raise_Error; ------------------- @@ -288,197 +106,20 @@ is Ru : Uns32; -- Unsigned quotient and remainder - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - - -- Local lemmas - - procedure Prove_Negative_Dividend - with - Ghost, - Pre => Z /= 0 - and then ((X >= 0 and Y < 0) or (X < 0 and Y >= 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => - (if Z > 0 then Big_Q <= Big_0 else Big_Q >= Big_0); - -- Proves the sign of rounded quotient when dividend is non-positive - - procedure Prove_Overflow - with - Ghost, - Pre => Z /= 0 and then Mult >= Big_2xx32 * Big (Uns32'(abs Z)), - Post => not In_Int32_Range (Big (X) * Big (Y) / Big (Z)) - and then not In_Int32_Range - (Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z))); - -- Proves overflow case - - procedure Prove_Positive_Dividend - with - Ghost, - Pre => Z /= 0 - and then ((X >= 0 and Y >= 0) or (X < 0 and Y < 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => - (if Z > 0 then Big_Q >= Big_0 else Big_Q <= Big_0); - -- Proves the sign of rounded quotient when dividend is non-negative - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Zu) = Big (Uns32'(abs Z)), - Post => abs Big_Q = - (if Ru > (Zu - Uns32'(1)) / Uns32'(2) - then abs Quot + 1 - else abs Quot); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Sign_R - with - Ghost, - Pre => Z /= 0 and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => In_Int32_Range (Big_R); - - procedure Prove_Signs - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - (if Round then - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then In_Int32_Range (Big_Q) - and then In_Int32_Range (Big_R) - and then R = - (if (X >= 0) = (Y >= 0) then To_Pos_Int (Ru) else To_Neg_Int (Ru)) - and then Q = - (if ((X >= 0) = (Y >= 0)) = (Z >= 0) then To_Pos_Int (Qu) - else To_Neg_Int (Qu)), -- need to ensure To_Pos_Int precondition - Post => Big (R) = Big_R and then Big (Q) = Big_Q; - -- Proves final signs match the intended result after the unsigned - -- division is done. - - ----------------------------- - -- Prove_Negative_Dividend -- - ----------------------------- - - procedure Prove_Negative_Dividend is - begin - Lemma_Mult_Non_Positive (Big (X), Big (Y)); - end Prove_Negative_Dividend; - - -------------------- - -- Prove_Overflow -- - -------------------- - - procedure Prove_Overflow is - begin - Lemma_Div_Ge (Mult, Big_2xx32, Big (Uns32'(abs Z))); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Overflow; - - ----------------------------- - -- Prove_Positive_Dividend -- - ----------------------------- - - procedure Prove_Positive_Dividend is - begin - Lemma_Mult_Non_Negative (Big (X), Big (Y)); - end Prove_Positive_Dividend; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X) * Big (Y), Big (Z)) then - pragma Assert - (abs Big_Q = - (if Ru > (Zu - Uns32'(1)) / Uns32'(2) - then abs Quot + 1 - else abs Quot)); - end if; - end Prove_Rounding_Case; - - ------------------ - -- Prove_Sign_R -- - ------------------ - - procedure Prove_Sign_R is - begin - pragma Assert (In_Int32_Range (Big (Z))); - end Prove_Sign_R; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is - begin - if (X >= 0) = (Y >= 0) then - pragma Assert (Big (R) = Big_R and then Big (Q) = Big_Q); - else - pragma Assert (Big (R) = Big_R and then Big (Q) = Big_Q); - end if; - end Prove_Signs; - - -- Start of processing for Scaled_Divide32 - begin -- First do the 64-bit multiplication D := Uns64 (Xu) * Uns64 (Yu); - Lemma_Abs_Mult_Commutation (Big (X), Big (Y)); - pragma Assert (Mult = Big (D)); - Lemma_Hi_Lo (D, Hi (D), Lo (D)); - pragma Assert (Mult = Big_2xx32 * Big (Hi (D)) + Big (Lo (D))); - -- If divisor is zero, raise error if Z = 0 then Raise_Error; end if; - Quot := Big (X) * Big (Y) / Big (Z); - Big_R := Big (X) * Big (Y) rem Big (Z); - if Round then - Big_Q := Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - -- If dividend is too large, raise error if Hi (D) >= Zu then - Lemma_Ge_Commutation (Hi (D), Zu); - pragma Assert (Mult >= Big_2xx32 * Big (Zu)); - Prove_Overflow; Raise_Error; end if; @@ -487,35 +128,14 @@ is Qu := Uns32 (D / Uns64 (Zu)); Ru := Uns32 (D rem Uns64 (Zu)); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Commutation (X); - Lemma_Abs_Commutation (Y); - Lemma_Abs_Commutation (Z); - Lemma_Mult_Commutation (Uns64 (Xu), Uns64 (Yu), D); - Lemma_Div_Commutation (D, Uns64 (Zu)); - Lemma_Rem_Commutation (D, Uns64 (Zu)); - - pragma Assert (Uns64 (Qu) = D / Uns64 (Zu)); - pragma Assert (Uns64 (Ru) = D rem Uns64 (Zu)); - pragma Assert (Big (Ru) = abs Big_R); - pragma Assert (Big (Qu) = abs Quot); - pragma Assert (Big (Zu) = Big (Uns32'(abs Z))); - -- Deal with rounding case if Round then - Prove_Rounding_Case; - if Ru > (Zu - Uns32'(1)) / Uns32'(2) then - pragma Assert (abs Big_Q = Big (Qu) + 1); - -- Protect against wrapping around when rounding, by signaling -- an overflow when the quotient is too large. if Qu = Uns32'Last then - pragma Assert (abs Big_Q = Big_2xx32); - Lemma_Not_In_Range_Big2xx32; Raise_Error; end if; @@ -523,31 +143,20 @@ is end if; end if; - pragma Assert (In_Int32_Range (Big_Q)); - pragma Assert (Big (Qu) = abs Big_Q); - pragma Assert (Big (Ru) = abs Big_R); - Prove_Sign_R; - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X * Y) sign positive if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then - Prove_Positive_Dividend; - R := To_Pos_Int (Ru); Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); -- Case of dividend (X * Y) sign negative else - Prove_Negative_Dividend; - R := To_Neg_Int (Ru); Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; - - Prove_Signs; end Scaled_Divide32; ---------------- @@ -559,6 +168,7 @@ is (if A = 2**31 then Int32'First else -To_Int (A)); -- Note that we can't just use the expression of the Else, because it -- overflows for A = 2**31. + begin if R <= 0 then return R; diff --git a/gcc/ada/libgnat/s-arit32.ads b/gcc/ada/libgnat/s-arit32.ads index a8abbdc..856dd59 100644 --- a/gcc/ada/libgnat/s-arit32.ads +++ b/gcc/ada/libgnat/s-arit32.ads @@ -33,79 +33,19 @@ -- signed integer values in cases where either overflow checking is -- required, or intermediate results are longer than 32 bits. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with Interfaces; -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; package System.Arith_32 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; use type Interfaces.Integer_32; subtype Int32 is Interfaces.Integer_32; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int32); - - function Big (Arg : Int32) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int32_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int32'First), Big (Int32'Last))) - with Ghost; - - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int32'(0)) - or else Y = Big (Int32'(0)) - or else (X < Big (Int32'(0))) = (Y < Big (Int32'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Int32'(1))) / Big (Int32'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int32'(1)) - else Q - Big (Int32'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide32 (X, Y, Z : Int32; Q, R : out Int32; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int32_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb index 331f328..4e0336f 100644 --- a/gcc/ada/libgnat/s-arit64.adb +++ b/gcc/ada/libgnat/s-arit64.adb @@ -28,14 +28,12 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -pragma Assertion_Policy (Ghost => Ignore); with System.Arith_Double; package body System.Arith_64 with SPARK_Mode is - subtype Uns64 is Interfaces.Unsigned_64; subtype Uns32 is Interfaces.Unsigned_32; @@ -52,9 +50,6 @@ is function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64 renames Impl.Multiply_With_Ovflo_Check; - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer - renames Impl.Round_Quotient; - procedure Scaled_Divide64 (X, Y, Z : Int64; Q, R : out Int64; diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads index 2ddd15c..6e12789 100644 --- a/gcc/ada/libgnat/s-arit64.ads +++ b/gcc/ada/libgnat/s-arit64.ads @@ -36,49 +36,14 @@ pragma Restrictions (No_Elaboration_Code); -- Allow direct call from gigi generated code --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Interfaces; package System.Arith_64 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - use type Interfaces.Integer_64; - subtype Int64 is Interfaces.Integer_64; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int64); - - function Big (Arg : Int64) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int64_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int64'First), Big (Int64'Last))) - with Ghost; - - function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check64'Result = X + Y; + function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64; -- Raises Constraint_Error if sum of operands overflows 64 bits, -- otherwise returns the 64-bit signed integer sum. -- @@ -93,10 +58,7 @@ is -- the exception *Constraint_Error* is raised; otherwise the result is -- correct. - function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check64'Result = X - Y; + function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64; -- Raises Constraint_Error if difference of operands overflows 64 -- bits, otherwise returns the 64-bit signed integer difference. -- @@ -105,10 +67,7 @@ is -- a sign of the result is compared with the sign of ``X`` to check for -- overflow. - function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check64'Result = X * Y; + function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64; pragma Export (C, Multiply_With_Ovflo_Check64, "__gnat_mulv64"); -- Raises Constraint_Error if product of operands overflows 64 -- bits, otherwise returns the 64-bit signed integer product. @@ -119,40 +78,10 @@ is -- signed value is returned. Overflow check is performed by looking at -- higher digits. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int64'(0)) - or else Y = Big (Int64'(0)) - or else (X < Big (Int64'(0))) = (Y < Big (Int64'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y, - Post => Round_Quotient'Result = - (if abs R > (abs Y - Big (Int64'(1))) / Big (Int64'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int64'(1)) - else Q - Big (Int64'(1))) - else - Q); - procedure Scaled_Divide64 (X, Y, Z : Int64; Q, R : out Int64; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int64_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- @@ -189,22 +118,7 @@ is procedure Double_Divide64 (X, Y, Z : Int64; Q, R : out Int64; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Int64_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division ``X`` / (``Y`` * ``Z``), storing the quotient in -- ``Q`` and the remainder in ``R``. Constraint_Error is raised if ``Y`` or -- ``Z`` is zero, or if the quotient does not fit in 64-bits. diff --git a/gcc/ada/libgnat/s-casuti.adb b/gcc/ada/libgnat/s-casuti.adb index 58c358c..af98791 100644 --- a/gcc/ada/libgnat/s-casuti.adb +++ b/gcc/ada/libgnat/s-casuti.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Case_Util with SPARK_Mode is @@ -62,9 +54,6 @@ is begin for J in A'Range loop A (J) := To_Lower (A (J)); - - pragma Loop_Invariant - (for all K in A'First .. J => A (K) = To_Lower (A'Loop_Entry (K))); end loop; end To_Lower; @@ -90,15 +79,6 @@ is A (J) := To_Lower (A (J)); end if; - pragma Loop_Invariant - (for all K in A'First .. J => - (if K = A'First - or else A'Loop_Entry (K - 1) = '_' - then - A (K) = To_Upper (A'Loop_Entry (K)) - else - A (K) = To_Lower (A'Loop_Entry (K)))); - Ucase := A (J) = '_'; end loop; end To_Mixed; @@ -132,9 +112,6 @@ is begin for J in A'Range loop A (J) := To_Upper (A (J)); - - pragma Loop_Invariant - (for all K in A'First .. J => A (K) = To_Upper (A'Loop_Entry (K))); end loop; end To_Upper; diff --git a/gcc/ada/libgnat/s-exnint.ads b/gcc/ada/libgnat/s-exnint.ads index 3a11f2c..fa46217 100644 --- a/gcc/ada/libgnat/s-exnint.ads +++ b/gcc/ada/libgnat/s-exnint.ads @@ -31,17 +31,6 @@ -- This package implements Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_Int diff --git a/gcc/ada/libgnat/s-exnlli.ads b/gcc/ada/libgnat/s-exnlli.ads index ba67b76..63c4b88 100644 --- a/gcc/ada/libgnat/s-exnlli.ads +++ b/gcc/ada/libgnat/s-exnlli.ads @@ -31,17 +31,6 @@ -- This package implements Long_Long_Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_LLI diff --git a/gcc/ada/libgnat/s-exnllli.ads b/gcc/ada/libgnat/s-exnllli.ads index 5ff963c..e94efe0 100644 --- a/gcc/ada/libgnat/s-exnllli.ads +++ b/gcc/ada/libgnat/s-exnllli.ads @@ -31,23 +31,11 @@ -- Long_Long_Long_Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_LLLI with SPARK_Mode is - package Exponn_Integer is new Exponn (Long_Long_Long_Integer); function Exn_Long_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-expint.ads b/gcc/ada/libgnat/s-expint.ads index a69c8d6..d349330 100644 --- a/gcc/ada/libgnat/s-expint.ads +++ b/gcc/ada/libgnat/s-expint.ads @@ -31,23 +31,11 @@ -- This package implements Integer exponentiation (checks on) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_Int with SPARK_Mode is - package Expont_Integer is new Expont (Integer); function Exp_Integer (Left : Integer; Right : Natural) return Integer diff --git a/gcc/ada/libgnat/s-explli.ads b/gcc/ada/libgnat/s-explli.ads index 9ea38de..af3da9c 100644 --- a/gcc/ada/libgnat/s-explli.ads +++ b/gcc/ada/libgnat/s-explli.ads @@ -31,23 +31,11 @@ -- This package implements Long_Long_Integer exponentiation --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_LLI with SPARK_Mode is - package Expont_Integer is new Expont (Long_Long_Integer); function Exp_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-expllli.ads b/gcc/ada/libgnat/s-expllli.ads index 273c33c..ed100b9 100644 --- a/gcc/ada/libgnat/s-expllli.ads +++ b/gcc/ada/libgnat/s-expllli.ads @@ -31,23 +31,11 @@ -- Long_Long_Long_Integer exponentiation (checks on) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_LLLI with SPARK_Mode is - package Expont_Integer is new Expont (Long_Long_Long_Integer); function Exp_Long_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-explllu.ads b/gcc/ada/libgnat/s-explllu.ads index a0b5d47..88aa9af 100644 --- a/gcc/ada/libgnat/s-explllu.ads +++ b/gcc/ada/libgnat/s-explllu.ads @@ -34,24 +34,12 @@ -- The result is always full width, the caller must do a masking operation if -- the modulus is less than 2 ** Long_Long_Long_Unsigned'Size. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_LLLU with SPARK_Mode is - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; function Exp_Long_Long_Long_Unsigned is diff --git a/gcc/ada/libgnat/s-expllu.ads b/gcc/ada/libgnat/s-expllu.ads index 98fc851..3e2b2a7 100644 --- a/gcc/ada/libgnat/s-expllu.ads +++ b/gcc/ada/libgnat/s-expllu.ads @@ -34,24 +34,12 @@ -- is always full width, the caller must do a masking operation if the -- modulus is less than 2 ** (Long_Long_Unsigned'Size). --- Note: preconditions in this unit are meant for analysis only, not for --- run-time checking, so that the expected exceptions are raised. This is --- enforced by setting the corresponding assertion policy to Ignore. --- Postconditions and contract cases should not be executed at run-time as --- well, in order not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_LLU with SPARK_Mode is - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; function Exp_Long_Long_Unsigned is new Exponu (Long_Long_Unsigned); diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb index 28c07a1..16d6b5f 100644 --- a/gcc/ada/libgnat/s-expmod.adb +++ b/gcc/ada/libgnat/s-expmod.adb @@ -29,203 +29,11 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - package body System.Exp_Mod with SPARK_Mode is use System.Unsigned_Types; - -- Local lemmas - - procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) - with - Ghost, - Post => (X + Y) mod B = ((X mod B) + (Y mod B)) mod B; - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_Mod (A : Big_Natural; Exp : Natural; B : Big_Positive) - with - Ghost, - Subprogram_Variant => (Decreases => Exp), - Post => ((A mod B) ** Exp) mod B = (A ** Exp) mod B; - - procedure Lemma_Mod_Ident (A : Big_Natural; B : Big_Positive) - with - Ghost, - Pre => A < B, - Post => A mod B = A; - - procedure Lemma_Mod_Mod (A : Big_Integer; B : Big_Positive) - with - Ghost, - Post => A mod B mod B = A mod B; - - procedure Lemma_Mult_Div (X : Big_Natural; Y : Big_Positive) - with - Ghost, - Post => X * Y / Y = X; - - procedure Lemma_Mult_Mod (X, Y : Big_Natural; B : Big_Positive) - with - Ghost, - -- The following subprogram variant can be added as soon as supported - -- Subprogram_Variant => (Decreases => Y), - Post => (X * Y) mod B = ((X mod B) * (Y mod B)) mod B; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Mod_Ident (A : Big_Natural; B : Big_Positive) is null; - procedure Lemma_Mod_Mod (A : Big_Integer; B : Big_Positive) is null; - procedure Lemma_Mult_Div (X : Big_Natural; Y : Big_Positive) is null; - - ------------------- - -- Lemma_Add_Mod -- - ------------------- - - procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) is - - procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) with - Pre => F /= 0, - Post => (Q * F + R) mod F = R mod F, - Subprogram_Variant => (Decreases => Q); - - ------------------------- - -- Lemma_Euclidean_Mod -- - ------------------------- - - procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) is - begin - if Q > 0 then - Lemma_Euclidean_Mod (Q - 1, F, R); - end if; - end Lemma_Euclidean_Mod; - - -- Local variables - - Left : constant Big_Natural := (X + Y) mod B; - Right : constant Big_Natural := ((X mod B) + (Y mod B)) mod B; - XQuot : constant Big_Natural := X / B; - YQuot : constant Big_Natural := Y / B; - AQuot : constant Big_Natural := (X mod B + Y mod B) / B; - begin - if Y /= 0 and B > 1 then - pragma Assert (X = XQuot * B + X mod B); - pragma Assert (Y = YQuot * B + Y mod B); - pragma Assert - (Left = ((XQuot + YQuot) * B + X mod B + Y mod B) mod B); - pragma Assert (X mod B + Y mod B = AQuot * B + Right); - pragma Assert (Left = ((XQuot + YQuot + AQuot) * B + Right) mod B); - Lemma_Euclidean_Mod (XQuot + YQuot + AQuot, B, Right); - pragma Assert (Left = (Right mod B)); - pragma Assert (Left = Right); - end if; - end Lemma_Add_Mod; - - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------- - -- Lemma_Exp_Mod -- - ------------------- - - procedure Lemma_Exp_Mod (A : Big_Natural; Exp : Natural; B : Big_Positive) - is - begin - if Exp /= 0 then - declare - Left : constant Big_Integer := ((A mod B) ** Exp) mod B; - Right : constant Big_Integer := (A ** Exp) mod B; - begin - Lemma_Mult_Mod (A mod B, (A mod B) ** (Exp - 1), B); - Lemma_Mod_Mod (A, B); - Lemma_Exp_Mod (A, Exp - 1, B); - Lemma_Mult_Mod (A, A ** (Exp - 1), B); - pragma Assert - ((A mod B) * (A mod B) ** (Exp - 1) = (A mod B) ** Exp); - pragma Assert (A * A ** (Exp - 1) = A ** Exp); - pragma Assert (Left = Right); - end; - end if; - end Lemma_Exp_Mod; - - -------------------- - -- Lemma_Mult_Mod -- - -------------------- - - procedure Lemma_Mult_Mod (X, Y : Big_Natural; B : Big_Positive) is - Left : constant Big_Natural := (X * Y) mod B; - Right : constant Big_Natural := ((X mod B) * (Y mod B)) mod B; - begin - if Y /= 0 and B > 1 then - Lemma_Add_Mod (X * (Y - 1), X, B); - Lemma_Mult_Mod (X, Y - 1, B); - Lemma_Mod_Mod (X, B); - Lemma_Add_Mod ((X mod B) * ((Y - 1) mod B), X mod B, B); - Lemma_Add_Mod (Y - 1, 1, B); - pragma Assert (((Y - 1) mod B + 1) mod B = Y mod B); - if (Y - 1) mod B + 1 < B then - Lemma_Mod_Ident ((Y - 1) mod B + 1, B); - Lemma_Mod_Mod ((X mod B) * (Y mod B), B); - pragma Assert (Left = Right); - else - pragma Assert (Y mod B = 0); - pragma Assert (Y / B * B = Y); - pragma Assert ((X * Y) mod B = (X * Y) - (X * Y) / B * B); - pragma Assert - ((X * Y) mod B = (X * Y) - (X * (Y / B) * B) / B * B); - Lemma_Mult_Div (X * (Y / B), B); - pragma Assert (Left = 0); - pragma Assert (Left = Right); - end if; - end if; - end Lemma_Mult_Mod; - ----------------- -- Exp_Modular -- ----------------- @@ -241,35 +49,7 @@ is function Mult (X, Y : Unsigned) return Unsigned is (Unsigned (Long_Long_Unsigned (X) * Long_Long_Unsigned (Y) - mod Long_Long_Unsigned (Modulus))) - with - Pre => Modulus /= 0; - -- Modular multiplication. Note that we can't take advantage of the - -- compiler's circuit, because the modulus is not known statically. - - -- Local ghost variables, functions and lemmas - - M : constant Big_Positive := Big (Modulus) with Ghost; - - function Equal_Modulo (X, Y : Big_Integer) return Boolean is - (X mod M = Y mod M) - with - Ghost, - Pre => Modulus /= 0; - - procedure Lemma_Mult (X, Y : Unsigned) - with - Ghost, - Post => Big (Mult (X, Y)) = (Big (X) * Big (Y)) mod M - and then Big (Mult (X, Y)) < M; - - procedure Lemma_Mult (X, Y : Unsigned) is - begin - pragma Assert (Big (Mult (X, Y)) = (Big (X) * Big (Y)) mod M); - end Lemma_Mult; - - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates + mod Long_Long_Unsigned (Modulus))); begin pragma Assert (Modulus /= 1); @@ -284,72 +64,18 @@ is if Exp /= 0 then loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Result < Modulus); - pragma Loop_Invariant (Equal_Modulo - (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right)); - pragma Loop_Variant (Decreases => Exp); - if Exp rem 2 /= 0 then - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - pragma Assert (Equal_Modulo - ((Big (Result) * Big (Factor)) * Big (Factor) ** (Exp - 1), - Big (Left) ** Right)); - pragma Assert (Big (Factor) >= 0); - Lemma_Mult_Mod (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Modulus)); - Lemma_Mult (Result, Factor); - Result := Mult (Result, Factor); - - Lemma_Mod_Ident (Big (Result), Big (Modulus)); - Lemma_Mod_Mod (Big (Factor) ** (Exp - 1), Big (Modulus)); - Lemma_Mult_Mod (Big (Result), - Big (Factor) ** (Exp - 1), - Big (Modulus)); - pragma Assert (Equal_Modulo - (Big (Result) * Big (Factor) ** (Exp - 1), - Big (Left) ** Right)); - Lemma_Exp_Expand (Big (Factor), Exp - 1); - pragma Assert (Exp / 2 = (Exp - 1) / 2); end if; - Lemma_Exp_Expand (Big (Factor), Exp); - Exp := Exp / 2; exit when Exp = 0; - Rest := Big (Factor) ** Exp; - pragma Assert (Equal_Modulo - (Big (Result) * (Rest * Rest), Big (Left) ** Right)); - Lemma_Exp_Mod (Big (Factor) * Big (Factor), Exp, Big (Modulus)); - pragma Assert - ((Big (Factor) * Big (Factor)) ** Exp = Rest * Rest); - pragma Assert (Equal_Modulo - ((Big (Factor) * Big (Factor)) ** Exp, - Rest * Rest)); - Lemma_Mult (Factor, Factor); - Factor := Mult (Factor, Factor); - - Lemma_Mod_Mod (Rest * Rest, Big (Modulus)); - Lemma_Mod_Ident (Big (Result), Big (Modulus)); - Lemma_Mult_Mod (Big (Result), Rest * Rest, Big (Modulus)); - pragma Assert (Big (Factor) >= 0); - Lemma_Mult_Mod (Big (Result), Big (Factor) ** Exp, - Big (Modulus)); - pragma Assert (Equal_Modulo - (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right)); end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right mod Big (Modulus)); end if; return Result; - end Exp_Modular; end System.Exp_Mod; diff --git a/gcc/ada/libgnat/s-expmod.ads b/gcc/ada/libgnat/s-expmod.ads index 47ba39e..509ffa4 100644 --- a/gcc/ada/libgnat/s-expmod.ads +++ b/gcc/ada/libgnat/s-expmod.ads @@ -36,19 +36,6 @@ -- Note that 1 is a binary modulus (2**0), so the compiler should not (and -- will not) call this function with Modulus equal to 1. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - with System.Unsigned_Types; package System.Exp_Mod @@ -57,30 +44,10 @@ is use type System.Unsigned_Types.Unsigned; subtype Unsigned is System.Unsigned_Types.Unsigned; - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Unsigned_Conversion is - new Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Unsigned_Conversions - (Int => Unsigned); - - function Big (Arg : Unsigned) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with Ghost; - - subtype Power_Of_2 is Unsigned with - Dynamic_Predicate => - Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0; - function Exp_Modular (Left : Unsigned; Modulus : Unsigned; - Right : Natural) return Unsigned - with - Pre => Modulus /= 0 and then Modulus not in Power_Of_2, - Post => Big (Exp_Modular'Result) = Big (Left) ** Right mod Big (Modulus); + Right : Natural) return Unsigned; -- Return the power of ``Left`` by ``Right` modulo ``Modulus``. -- -- This function is implemented using the standard logarithmic approach: diff --git a/gcc/ada/libgnat/s-exponn.adb b/gcc/ada/libgnat/s-exponn.adb index ff79f5a..2aeb199 100644 --- a/gcc/ada/libgnat/s-exponn.adb +++ b/gcc/ada/libgnat/s-exponn.adb @@ -32,65 +32,6 @@ package body System.Exponn with SPARK_Mode is - - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - -- Local lemmas - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) - with - Ghost, - Pre => In_Int_Range (A ** Exp * A ** Exp), - Post => In_Int_Range (A * A); - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => A ** Exp /= 0; - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0 - and then Exp rem 2 = 0, - Post => A ** Exp > 0; - - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Y /= 0 - and then not (X = -Big (Int'First) and Y = -1) - and then X * Y = Z - and then In_Int_Range (Z), - Post => In_Int_Range (X); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) is null; - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) is null; - ----------- -- Expon -- ----------- @@ -104,13 +45,7 @@ is Factor : Int := Left; Exp : Natural := Right; - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); - -- We use the standard logarithmic approach, Exp gets shifted right -- testing successive low order bits and Factor is the value of the -- base raised to the next power of 2. @@ -122,117 +57,31 @@ is -- simpler, so we do it. if Right = 0 then - return 1; + Result := 1; elsif Left = 0 then - return 0; - end if; - - loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Factor /= 0); - pragma Loop_Invariant - (Big (Result) * Big (Factor) ** Exp = Big (Left) ** Right); - pragma Loop_Variant (Decreases => Exp); + Result := 0; + else + loop + if Exp rem 2 /= 0 then + declare + pragma Suppress (Overflow_Check); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; - if Exp rem 2 /= 0 then declare pragma Suppress (Overflow_Check); begin - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - Lemma_Exp_Positive (Big (Factor), Exp - 1); - Lemma_Mult_In_Range (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Left) ** Right); - - Result := Result * Factor; + Factor := Factor * Factor; end; - end if; - - Lemma_Exp_Expand (Big (Factor), Exp); - - Exp := Exp / 2; - exit when Exp = 0; - - Rest := Big (Factor) ** Exp; - pragma Assert - (Big (Result) * (Rest * Rest) = Big (Left) ** Right); - - declare - pragma Suppress (Overflow_Check); - begin - Lemma_Mult_In_Range (Rest * Rest, - Big (Result), - Big (Left) ** Right); - Lemma_Exp_In_Range (Big (Factor), Exp); - - Factor := Factor * Factor; - end; - - pragma Assert (Big (Factor) ** Exp = Rest * Rest); - end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right); + end loop; + end if; return Result; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Expon; - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => A /= 0 and then Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------------ - -- Lemma_Exp_In_Range -- - ------------------------ - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) is - begin - if A /= 0 and Exp /= 1 then - pragma Assert (A ** Exp = A * A ** (Exp - 1)); - Lemma_Mult_In_Range - (A * A, A ** (Exp - 1) * A ** (Exp - 1), A ** Exp * A ** Exp); - end if; - end Lemma_Exp_In_Range; - - ------------------------ - -- Lemma_Exp_Positive -- - ------------------------ - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) is - begin - if Exp = 0 then - pragma Assert (A ** Exp = 1); - else - pragma Assert (Exp = 2 * (Exp / 2)); - pragma Assert (A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)); - pragma Assert (A ** Exp = (A ** (Exp / 2)) ** 2); - Lemma_Exp_Not_Zero (A, Exp / 2); - end if; - end Lemma_Exp_Positive; - end System.Exponn; diff --git a/gcc/ada/libgnat/s-exponn.ads b/gcc/ada/libgnat/s-exponn.ads index 16bd393..94da5d2 100644 --- a/gcc/ada/libgnat/s-exponn.ads +++ b/gcc/ada/libgnat/s-exponn.ads @@ -32,44 +32,13 @@ -- This package provides functions for signed integer exponentiation. This -- is the version of the package with checks disabled. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Int is range <>; package System.Exponn with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is new BI_Ghost.Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last))) - with Ghost; - - function Expon (Left : Int; Right : Natural) return Int - with - Pre => In_Int_Range (Big (Left) ** Right), - Post => Expon'Result = Left ** Right; + function Expon (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-expont.adb b/gcc/ada/libgnat/s-expont.adb index 39476a9..368dd0b 100644 --- a/gcc/ada/libgnat/s-expont.adb +++ b/gcc/ada/libgnat/s-expont.adb @@ -32,65 +32,6 @@ package body System.Expont with SPARK_Mode is - - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - -- Local lemmas - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) - with - Ghost, - Pre => In_Int_Range (A ** Exp * A ** Exp), - Post => In_Int_Range (A * A); - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => A ** Exp /= 0; - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0 - and then Exp rem 2 = 0, - Post => A ** Exp > 0; - - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Y /= 0 - and then not (X = -Big (Int'First) and Y = -1) - and then X * Y = Z - and then In_Int_Range (Z), - Post => In_Int_Range (X); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) is null; - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) is null; - ----------- -- Expon -- ----------- @@ -104,13 +45,7 @@ is Factor : Int := Left; Exp : Natural := Right; - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); - -- We use the standard logarithmic approach, Exp gets shifted right -- testing successive low order bits and Factor is the value of the -- base raised to the next power of 2. @@ -122,117 +57,31 @@ is -- simpler, so we do it. if Right = 0 then - return 1; + Result := 1; elsif Left = 0 then - return 0; - end if; - - loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Factor /= 0); - pragma Loop_Invariant - (Big (Result) * Big (Factor) ** Exp = Big (Left) ** Right); - pragma Loop_Variant (Decreases => Exp); + Result := 0; + else + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (Overflow_Check); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; - if Exp rem 2 /= 0 then declare pragma Unsuppress (Overflow_Check); begin - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - Lemma_Exp_Positive (Big (Factor), Exp - 1); - Lemma_Mult_In_Range (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Left) ** Right); - - Result := Result * Factor; + Factor := Factor * Factor; end; - end if; - - Lemma_Exp_Expand (Big (Factor), Exp); - - Exp := Exp / 2; - exit when Exp = 0; - - Rest := Big (Factor) ** Exp; - pragma Assert - (Big (Result) * (Rest * Rest) = Big (Left) ** Right); - - declare - pragma Unsuppress (Overflow_Check); - begin - Lemma_Mult_In_Range (Rest * Rest, - Big (Result), - Big (Left) ** Right); - Lemma_Exp_In_Range (Big (Factor), Exp); - - Factor := Factor * Factor; - end; - - pragma Assert (Big (Factor) ** Exp = Rest * Rest); - end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right); + end loop; + end if; return Result; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Expon; - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => A /= 0 and then Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------------ - -- Lemma_Exp_In_Range -- - ------------------------ - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) is - begin - if A /= 0 and Exp /= 1 then - pragma Assert (A ** Exp = A * A ** (Exp - 1)); - Lemma_Mult_In_Range - (A * A, A ** (Exp - 1) * A ** (Exp - 1), A ** Exp * A ** Exp); - end if; - end Lemma_Exp_In_Range; - - ------------------------ - -- Lemma_Exp_Positive -- - ------------------------ - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) is - begin - if Exp = 0 then - pragma Assert (A ** Exp = 1); - else - pragma Assert (Exp = 2 * (Exp / 2)); - pragma Assert (A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)); - pragma Assert (A ** Exp = (A ** (Exp / 2)) ** 2); - Lemma_Exp_Not_Zero (A, Exp / 2); - end if; - end Lemma_Exp_Positive; - end System.Expont; diff --git a/gcc/ada/libgnat/s-expont.ads b/gcc/ada/libgnat/s-expont.ads index 880e054..2cf6dc0 100644 --- a/gcc/ada/libgnat/s-expont.ads +++ b/gcc/ada/libgnat/s-expont.ads @@ -32,44 +32,13 @@ -- This package provides functions for signed integer exponentiation. This -- is the version of the package with checks enabled. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Int is range <>; package System.Expont with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is new BI_Ghost.Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last))) - with Ghost; - - function Expon (Left : Int; Right : Natural) return Int - with - Pre => In_Int_Range (Big (Left) ** Right), - Post => Expon'Result = Left ** Right; + function Expon (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-exponu.adb b/gcc/ada/libgnat/s-exponu.adb index abb1930..0c52833 100644 --- a/gcc/ada/libgnat/s-exponu.adb +++ b/gcc/ada/libgnat/s-exponu.adb @@ -29,20 +29,7 @@ -- -- ------------------------------------------------------------------------------ -function System.Exponu (Left : Int; Right : Natural) return Int - with SPARK_Mode -is - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - +function System.Exponu (Left : Int; Right : Natural) return Int is -- Note that negative exponents get a constraint error because the -- subtype of the Right argument (the exponent) is Natural. @@ -61,16 +48,7 @@ begin if Exp /= 0 then loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Result * Factor ** Exp = Left ** Right); - pragma Loop_Variant (Decreases => Exp); - if Exp rem 2 /= 0 then - pragma Assert - (Result * (Factor * Factor ** (Exp - 1)) = Left ** Right); - pragma Assert - ((Result * Factor) * Factor ** (Exp - 1) = Left ** Right); - Result := Result * Factor; end if; diff --git a/gcc/ada/libgnat/s-exponu.ads b/gcc/ada/libgnat/s-exponu.ads index cfa6d78..7cc2f9c 100644 --- a/gcc/ada/libgnat/s-exponu.ads +++ b/gcc/ada/libgnat/s-exponu.ads @@ -31,25 +31,10 @@ -- This function implements unsigned integer exponentiation --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - generic - type Int is mod <>; -function System.Exponu (Left : Int; Right : Natural) return Int -with - SPARK_Mode, - Post => System.Exponu'Result = Left ** Right; +function System.Exponu (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-expuns.ads b/gcc/ada/libgnat/s-expuns.ads index 98ad607..d1dcc25 100644 --- a/gcc/ada/libgnat/s-expuns.ads +++ b/gcc/ada/libgnat/s-expuns.ads @@ -35,24 +35,12 @@ -- The result is always full width, the caller must do a masking operation -- the modulus is less than 2 ** (Unsigned'Size). --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_Uns with SPARK_Mode is - subtype Unsigned is Unsigned_Types.Unsigned; function Exp_Unsigned is new Exponu (Unsigned); diff --git a/gcc/ada/libgnat/s-imaged.adb b/gcc/ada/libgnat/s-imaged.adb index 34c15b0..638e37b 100644 --- a/gcc/ada/libgnat/s-imaged.adb +++ b/gcc/ada/libgnat/s-imaged.adb @@ -31,33 +31,10 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; -with System.Value_I_Spec; -with System.Value_U_Spec; package body System.Image_D is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Assert => Ignore, - Assert_And_Cut => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - - package Uns_Spec is new System.Value_U_Spec (Uns); - package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec); - - package Image_I is new System.Image_I - (Int => Int, - Uns => Uns, - U_Spec => Uns_Spec, - I_Spec => Int_Spec); + package Image_I is new System.Image_I (Int); procedure Set_Image_Integer (V : Int; @@ -76,7 +53,6 @@ package body System.Image_D is Scale : Integer) is pragma Assert (S'First = 1); - begin -- Add space at start for non-negative numbers diff --git a/gcc/ada/libgnat/s-imaged.ads b/gcc/ada/libgnat/s-imaged.ads index 1b83a67..48d4b00 100644 --- a/gcc/ada/libgnat/s-imaged.ads +++ b/gcc/ada/libgnat/s-imaged.ads @@ -34,10 +34,7 @@ -- types. generic - type Int is range <>; - type Uns is mod <>; - package System.Image_D is procedure Image_Decimal diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb index 00b4ac5..c84f424 100644 --- a/gcc/ada/libgnat/s-imagef.adb +++ b/gcc/ada/libgnat/s-imagef.adb @@ -31,25 +31,9 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; -with System.Value_I_Spec; -with System.Value_U_Spec; package body System.Image_F is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Assert => Ignore, - Assert_And_Cut => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - Maxdigs : constant Natural := Int'Width - 2; -- Maximum number of decimal digits that can be represented in an Int. -- The "-2" accounts for the sign and one extra digit, since we need the @@ -70,14 +54,7 @@ package body System.Image_F is -- if the small is larger than 1, and smaller than 2**(Int'Size - 1) / 10 -- if the small is smaller than 1. - package Uns_Spec is new System.Value_U_Spec (Uns); - package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec); - - package Image_I is new System.Image_I - (Int => Int, - Uns => Uns, - U_Spec => Uns_Spec, - I_Spec => Int_Spec); + package Image_I is new System.Image_I (Int); procedure Set_Image_Integer (V : Int; @@ -233,7 +210,6 @@ package body System.Image_F is Aft0 : Natural) is pragma Assert (S'First = 1); - begin -- Add space at start for non-negative numbers diff --git a/gcc/ada/libgnat/s-imagef.ads b/gcc/ada/libgnat/s-imagef.ads index fea63c6..f73eed8 100644 --- a/gcc/ada/libgnat/s-imagef.ads +++ b/gcc/ada/libgnat/s-imagef.ads @@ -34,9 +34,7 @@ -- point types whose Small is the ratio of two Int values. generic - type Int is range <>; - type Uns is mod <>; with procedure Scaled_Divide (X, Y, Z : Int; diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb index e6aaf83..0f2211b 100644 --- a/gcc/ada/libgnat/s-imagei.adb +++ b/gcc/ada/libgnat/s-imagei.adb @@ -29,106 +29,18 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - -with System.Val_Spec; - package body System.Image_I is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - subtype Non_Positive is Int range Int'First .. 0; - function Uns_Of_Non_Positive (T : Non_Positive) return Uns is - (if T = Int'First then Uns (Int'Last) + 1 else Uns (-T)); - procedure Set_Digits (T : Non_Positive; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then P <= S'Last - Unsigned_Width_Ghost + 1, - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then P in P'Old + 1 .. S'Last - and then UP.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) - and then UP.Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) - = UP.Wrap_Option (Uns_Of_Non_Positive (T)); + P : in out Natural); -- Set digits of absolute value of T, which is zero or negative. We work -- with the negative of the value so that the largest negative number is -- not a special case. - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - function From_Big (Arg : Big_Integer) return Uns renames - Unsigned_Conversion.From_Big_Integer; - - Big_10 : constant Big_Integer := Big (10) with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Non_Zero (X : Uns) - with - Ghost, - Pre => X /= 0, - Post => Big (X) /= 0; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Non_Zero (X : Uns) is null; - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - ------------------- -- Image_Integer -- ------------------- @@ -139,44 +51,6 @@ package body System.Image_I is P : out Natural) is pragma Assert (S'First = 1); - - procedure Prove_Value_Integer - with - Ghost, - Pre => S'First = 1 - and then S'Last < Integer'Last - and then P in 2 .. S'Last - and then S (1) in ' ' | '-' - and then (S (1) = '-') = (V < 0) - and then UP.Only_Decimal_Ghost (S, From => 2, To => P) - and then UP.Scan_Based_Number_Ghost (S, From => 2, To => P) - = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V)), - Post => not System.Val_Spec.Only_Space_Ghost (S, 1, P) - and then IP.Is_Integer_Ghost (S (1 .. P)) - and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); - -- Ghost lemma to prove the value of Value_Integer from the value of - -- Scan_Based_Number_Ghost and the sign on a decimal string. - - ------------------------- - -- Prove_Value_Integer -- - ------------------------- - - procedure Prove_Value_Integer is - Str : constant String := S (1 .. P); - begin - pragma Assert (Str'First = 1); - pragma Assert (Str (2) /= ' '); - pragma Assert - (UP.Only_Decimal_Ghost (Str, From => 2, To => P)); - UP.Prove_Scan_Based_Number_Ghost_Eq (S, Str, From => 2, To => P); - pragma Assert - (UP.Scan_Based_Number_Ghost (Str, From => 2, To => P) - = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V))); - IP.Prove_Scan_Only_Decimal_Ghost (Str, V); - end Prove_Value_Integer; - - -- Start of processing for Image_Integer - begin if V >= 0 then pragma Annotate (CodePeer, False_Positive, "test always false", @@ -190,18 +64,7 @@ package body System.Image_I is pragma Assert (P < S'Last - 1); end if; - declare - P_Prev : constant Integer := P with Ghost; - Offset : constant Positive := (if V >= 0 then 1 else 2) with Ghost; - begin - Set_Image_Integer (V, S, P); - - pragma Assert (P_Prev + Offset = 2); - end; - pragma Assert (if V >= 0 then S (1) = ' '); - pragma Assert (S (1) in ' ' | '-'); - - Prove_Value_Integer; + Set_Image_Integer (V, S, P); end Image_Integer; ---------------- @@ -215,136 +78,6 @@ package body System.Image_I is is Nb_Digits : Natural := 0; Value : Non_Positive := T; - - -- Local ghost variables - - Pow : Big_Positive := 1 with Ghost; - S_Init : constant String := S with Ghost; - Uns_T : constant Uns := Uns_Of_Non_Positive (T) with Ghost; - Uns_Value : Uns := Uns_Of_Non_Positive (Value) with Ghost; - Prev_Value : Uns with Ghost; - Prev_S : String := S with Ghost; - - -- Local ghost lemmas - - procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) - with - Ghost, - Post => RU rem 10 in 0 .. 9 - and then -(RI rem 10) in 0 .. 9 - and then Character'Val (48 + RU rem 10) in '0' .. '9' - and then Character'Val (48 - RI rem 10) in '0' .. '9'; - -- Ghost lemma to prove the value of a character corresponding to the - -- next figure. - - procedure Prove_Euclidian (Val, Quot, Rest : Uns) - with - Ghost, - Pre => Quot = Val / 10 - and then Rest = Val rem 10, - Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by 10 and the initial value. - - procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) - with - Ghost, - Pre => RU in 0 .. 9 - and then RI in 0 .. 9, - Post => UP.Hexa_To_Unsigned_Ghost - (Character'Val (48 + RU)) = RU - and then UP.Hexa_To_Unsigned_Ghost - (Character'Val (48 + RI)) = Uns (RI); - -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source - -- figure when applied to the corresponding character. - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - with - Ghost, - Pre => - S'First = Prev_S'First and then S'Last = Prev_S'Last - and then S'Last < Natural'Last and then - Max in S'Range and then P in S'First .. Max and then - (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') - and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) - and then S (P) in '0' .. '9' - and then V <= Uns'Last / 10 - and then Uns'Last - UP.Hexa_To_Unsigned_Ghost (S (P)) - >= 10 * V - and then Prev_V = - V * 10 + UP.Hexa_To_Unsigned_Ghost (S (P)) - and then - (if P = Max then Prev_V = Res - else UP.Scan_Based_Number_Ghost - (Str => Prev_S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V) = UP.Wrap_Option (Res)), - Post => - (for all I in P .. Max => S (I) in '0' .. '9') - and then UP.Scan_Based_Number_Ghost - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V) = UP.Wrap_Option (Res); - -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved - -- through an iteration of the loop. - - procedure Prove_Uns_Of_Non_Positive_Value - with - Ghost, - Pre => Uns_Value = Uns_Of_Non_Positive (Value), - Post => Uns_Value / 10 = Uns_Of_Non_Positive (Value / 10) - and then Uns_Value rem 10 = Uns_Of_Non_Positive (Value rem 10); - -- Ghost lemma to prove that the relation between Value and its unsigned - -- version is preserved. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) is null; - procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; - procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) is null; - procedure Prove_Uns_Of_Non_Positive_Value is null; - - --------------------- - -- Prove_Scan_Iter -- - --------------------- - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - is - pragma Unreferenced (Res); - begin - UP.Lemma_Scan_Based_Number_Ghost_Step - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V); - if P < Max then - UP.Prove_Scan_Based_Number_Ghost_Eq - (Prev_S, S, P + 1, Max, 10, Prev_V); - else - UP.Lemma_Scan_Based_Number_Ghost_Base - (Str => S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V); - end if; - end Prove_Scan_Iter; - - -- Start of processing for Set_Digits - begin pragma Assert (P >= S'First - 1 and P < S'Last); -- No check is done since, as documented in the Set_Image_Integer @@ -354,90 +87,20 @@ package body System.Image_I is -- First we compute the number of characters needed for representing -- the number. loop - Lemma_Div_Commutation (Uns_Of_Non_Positive (Value), 10); - Lemma_Div_Twice (Big (Uns_Of_Non_Positive (T)), - Big_10 ** Nb_Digits, Big_10); - Prove_Uns_Of_Non_Positive_Value; - Value := Value / 10; Nb_Digits := Nb_Digits + 1; - Uns_Value := Uns_Value / 10; - Pow := Pow * 10; - - pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); - pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1); - pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits); - pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); - pragma Loop_Variant (Increases => Value); - exit when Value = 0; - - Lemma_Non_Zero (Uns_Value); - pragma Assert (Pow <= Big (Uns'Last)); end loop; Value := T; - Uns_Value := Uns_Of_Non_Positive (T); - Pow := 1; - - pragma Assert (Uns_Value = From_Big (Big (Uns_T) / Big_10 ** 0)); -- We now populate digits from the end of the string to the beginning for J in reverse 1 .. Nb_Digits loop - Lemma_Div_Commutation (Uns_Value, 10); - Lemma_Div_Twice (Big (Uns_T), Big_10 ** (Nb_Digits - J), Big_10); - Prove_Character_Val (Uns_Value, Value); - Prove_Hexa_To_Unsigned_Ghost (Uns_Value rem 10, -(Value rem 10)); - Prove_Uns_Of_Non_Positive_Value; - - Prev_Value := Uns_Value; - Prev_S := S; - Pow := Pow * 10; - Uns_Value := Uns_Value / 10; - S (P + J) := Character'Val (48 - (Value rem 10)); Value := Value / 10; - - Prove_Euclidian - (Val => Prev_Value, - Quot => Uns_Value, - Rest => UP.Hexa_To_Unsigned_Ghost (S (P + J))); - - Prove_Scan_Iter - (S, Prev_S, Uns_Value, Prev_Value, Uns_T, P + J, P + Nb_Digits); - - pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); - pragma Loop_Invariant (Uns_Value <= Uns'Last / 10); - pragma Loop_Invariant - (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant - (UP.Only_Decimal_Ghost (S, P + J, P + Nb_Digits)); - pragma Loop_Invariant - (for all K in P + J .. P + Nb_Digits => S (K) in '0' .. '9'); - pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); - pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); - pragma Loop_Invariant - (UP.Scan_Based_Number_Ghost - (Str => S, - From => P + J, - To => P + Nb_Digits, - Base => 10, - Acc => Uns_Value) - = UP.Wrap_Option (Uns_T)); end loop; - pragma Assert (Big (Uns_Value) = Big (Uns_T) / Big_10 ** (Nb_Digits)); - pragma Assert (Uns_Value = 0); - pragma Assert - (UP.Scan_Based_Number_Ghost - (Str => S, - From => P + 1, - To => P + Nb_Digits, - Base => 10, - Acc => Uns_Value) - = UP.Wrap_Option (Uns_T)); - P := P + Nb_Digits; end Set_Digits; @@ -448,12 +111,10 @@ package body System.Image_I is procedure Set_Image_Integer (V : Int; S : in out String; - P : in out Natural) - is + P : in out Natural) is begin if V >= 0 then Set_Digits (-V, S, P); - else pragma Assert (P >= S'First - 1 and P < S'Last); -- No check is done since, as documented in the specification, diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads index e500f74..8d3b939 100644 --- a/gcc/ada/libgnat/s-imagei.ads +++ b/gcc/ada/libgnat/s-imagei.ads @@ -33,48 +33,14 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_I_Spec; -with System.Value_U_Spec; - generic type Int is range <>; - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - with package I_Spec is new System.Value_I_Spec - (Int => Int, Uns => Uns, U_Spec => U_Spec) with Ghost; - package System.Image_I is - package IP renames I_Spec; - package UP renames U_Spec; - use type UP.Uns_Option; - - Unsigned_Width_Ghost : constant Natural := U_Spec.Max_Log10 + 2 with Ghost; procedure Image_Integer (V : Int; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then S'Last < Integer'Last - and then S'Last >= Unsigned_Width_Ghost, - Post => P in S'Range - and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); + P : out Natural); -- Computes Int'Image (V) and stores the result in S (1 .. P) -- setting the resulting value of P. The caller guarantees that S -- is long enough to hold the result, and that S'First is 1. @@ -82,31 +48,7 @@ package System.Image_I is procedure Set_Image_Integer (V : Int; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then - (if V >= 0 then - P <= S'Last - Unsigned_Width_Ghost + 1 - else - P <= S'Last - Unsigned_Width_Ghost), - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then - (declare - Minus : constant Boolean := S (P'Old + 1) = '-'; - Offset : constant Positive := (if V >= 0 then 1 else 2); - Abs_V : constant Uns := IP.Abs_Uns_Of_Int (V); - begin - Minus = (V < 0) - and then P in P'Old + Offset .. S'Last - and then UP.Only_Decimal_Ghost - (S, From => P'Old + Offset, To => P) - and then UP.Scan_Based_Number_Ghost - (S, From => P'Old + Offset, To => P) - = UP.Wrap_Option (Abs_V)); + P : in out Natural); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Int'Image (V) except that no leading space is stored when V is diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb index 820156b..a6cdfed 100644 --- a/gcc/ada/libgnat/s-imageu.adb +++ b/gcc/ada/libgnat/s-imageu.adb @@ -29,79 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -with System.Val_Spec; - package body System.Image_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - function From_Big (Arg : Big_Integer) return Uns renames - Unsigned_Conversion.From_Big_Integer; - - Big_10 : constant Big_Integer := Big (10) with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Non_Zero (X : Uns) - with - Ghost, - Pre => X /= 0, - Post => Big (X) /= 0; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Non_Zero (X : Uns) is null; - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - -------------------- -- Image_Unsigned -- -------------------- @@ -112,50 +41,10 @@ package body System.Image_U is P : out Natural) is pragma Assert (S'First = 1); - - procedure Prove_Value_Unsigned - with - Ghost, - Pre => S'First = 1 - and then S'Last < Integer'Last - and then P in 2 .. S'Last - and then S (1) = ' ' - and then U_Spec.Only_Decimal_Ghost (S, From => 2, To => P) - and then U_Spec.Scan_Based_Number_Ghost (S, From => 2, To => P) - = U_Spec.Wrap_Option (V), - Post => not System.Val_Spec.Only_Space_Ghost (S, 1, P) - and then U_Spec.Is_Unsigned_Ghost (S (1 .. P)) - and then U_Spec.Is_Value_Unsigned_Ghost (S (1 .. P), V); - -- Ghost lemma to prove the value of Value_Unsigned from the value of - -- Scan_Based_Number_Ghost on a decimal string. - - -------------------------- - -- Prove_Value_Unsigned -- - -------------------------- - - procedure Prove_Value_Unsigned is - Str : constant String := S (1 .. P); - begin - pragma Assert (Str'First = 1); - pragma Assert (S (2) /= ' '); - pragma Assert - (U_Spec.Only_Decimal_Ghost (Str, From => 2, To => P)); - U_Spec.Prove_Scan_Based_Number_Ghost_Eq - (S, Str, From => 2, To => P); - pragma Assert - (U_Spec.Scan_Based_Number_Ghost (Str, From => 2, To => P) - = U_Spec.Wrap_Option (V)); - U_Spec.Prove_Scan_Only_Decimal_Ghost (Str, V); - end Prove_Value_Unsigned; - - -- Start of processing for Image_Unsigned - begin S (1) := ' '; P := 1; Set_Image_Unsigned (V, S, P); - - Prove_Value_Unsigned; end Image_Unsigned; ------------------------ @@ -169,118 +58,6 @@ package body System.Image_U is is Nb_Digits : Natural := 0; Value : Uns := V; - - -- Local ghost variables - - Pow : Big_Positive := 1 with Ghost; - S_Init : constant String := S with Ghost; - Prev_Value : Uns with Ghost; - Prev_S : String := S with Ghost; - - -- Local ghost lemmas - - procedure Prove_Character_Val (R : Uns) - with - Ghost, - Post => R rem 10 in 0 .. 9 - and then Character'Val (48 + R rem 10) in '0' .. '9'; - -- Ghost lemma to prove the value of a character corresponding to the - -- next figure. - - procedure Prove_Euclidian (Val, Quot, Rest : Uns) - with - Ghost, - Pre => Quot = Val / 10 - and then Rest = Val rem 10, - Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by 10 and the initial value. - - procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns) - with - Ghost, - Pre => R in 0 .. 9, - Post => U_Spec.Hexa_To_Unsigned_Ghost (Character'Val (48 + R)) = R; - -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source - -- figure when applied to the corresponding character. - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - with - Ghost, - Pre => - S'First = Prev_S'First and then S'Last = Prev_S'Last - and then S'Last < Natural'Last and then - Max in S'Range and then P in S'First .. Max and then - (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') - and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) - and then S (P) in '0' .. '9' - and then V <= Uns'Last / 10 - and then Uns'Last - U_Spec.Hexa_To_Unsigned_Ghost (S (P)) - >= 10 * V - and then Prev_V = - V * 10 + U_Spec.Hexa_To_Unsigned_Ghost (S (P)) - and then - (if P = Max then Prev_V = Res - else U_Spec.Scan_Based_Number_Ghost - (Str => Prev_S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V) = U_Spec.Wrap_Option (Res)), - Post => - (for all I in P .. Max => S (I) in '0' .. '9') - and then U_Spec.Scan_Based_Number_Ghost - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V) = U_Spec.Wrap_Option (Res); - -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved - -- through an iteration of the loop. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Character_Val (R : Uns) is null; - procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; - procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns) is null; - - --------------------- - -- Prove_Scan_Iter -- - --------------------- - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - is - pragma Unreferenced (Res); - begin - U_Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V); - if P < Max then - U_Spec.Prove_Scan_Based_Number_Ghost_Eq - (Prev_S, S, P + 1, Max, 10, Prev_V); - else - U_Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str => S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V); - end if; - end Prove_Scan_Iter; - - -- Start of processing for Set_Image_Unsigned - begin pragma Assert (P >= S'First - 1 and then P < S'Last and then P < Natural'Last); @@ -290,70 +67,19 @@ package body System.Image_U is -- First we compute the number of characters needed for representing -- the number. loop - Lemma_Div_Commutation (Value, 10); - Lemma_Div_Twice (Big (V), Big_10 ** Nb_Digits, Big_10); - Value := Value / 10; Nb_Digits := Nb_Digits + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1); - pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits); - pragma Loop_Invariant (Big (Value) = Big (V) / Pow); - pragma Loop_Variant (Decreases => Value); exit when Value = 0; - - Lemma_Non_Zero (Value); - pragma Assert (Pow <= Big (Uns'Last)); end loop; - pragma Assert (Big (V) / (Big_10 ** Nb_Digits) = 0); Value := V; - Pow := 1; - - pragma Assert (Value = From_Big (Big (V) / Big_10 ** 0)); -- We now populate digits from the end of the string to the beginning for J in reverse 1 .. Nb_Digits loop - Lemma_Div_Commutation (Value, 10); - Lemma_Div_Twice (Big (V), Big_10 ** (Nb_Digits - J), Big_10); - Prove_Character_Val (Value); - Prove_Hexa_To_Unsigned_Ghost (Value rem 10); - - Prev_Value := Value; - Prev_S := S; - Pow := Pow * 10; S (P + J) := Character'Val (48 + (Value rem 10)); Value := Value / 10; - - Prove_Euclidian - (Val => Prev_Value, - Quot => Value, - Rest => U_Spec.Hexa_To_Unsigned_Ghost (S (P + J))); - - Prove_Scan_Iter - (S, Prev_S, Value, Prev_Value, V, P + J, P + Nb_Digits); - - pragma Loop_Invariant (Value <= Uns'Last / 10); - pragma Loop_Invariant - (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant - (U_Spec.Only_Decimal_Ghost - (S, From => P + J, To => P + Nb_Digits)); - pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); - pragma Loop_Invariant (Big (Value) = Big (V) / Pow); - pragma Loop_Invariant - (U_Spec.Scan_Based_Number_Ghost - (Str => S, - From => P + J, - To => P + Nb_Digits, - Base => 10, - Acc => Value) - = U_Spec.Wrap_Option (V)); end loop; - pragma Assert (Big (Value) = Big (V) / (Big_10 ** Nb_Digits)); - pragma Assert (Value = 0); P := P + Nb_Digits; end Set_Image_Unsigned; diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads index 720de40..8640a5b 100644 --- a/gcc/ada/libgnat/s-imageu.ads +++ b/gcc/ada/libgnat/s-imageu.ads @@ -33,44 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for modular integer -- types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; - generic - type Uns is mod <>; - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - package System.Image_U is - use all type U_Spec.Uns_Option; - - Unsigned_Width_Ghost : constant Natural := U_Spec.Max_Log10 + 2 with Ghost; procedure Image_Unsigned (V : Uns; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then S'Last < Integer'Last - and then S'Last >= Unsigned_Width_Ghost, - Post => P in S'Range - and then U_Spec.Is_Value_Unsigned_Ghost (S (1 .. P), V); - pragma Inline (Image_Unsigned); + P : out Natural) with Inline; -- Computes Uns'Image (V) and stores the result in S (1 .. P) setting -- the resulting value of P. The caller guarantees that S is long enough to -- hold the result, and that S'First is 1. @@ -78,19 +49,7 @@ package System.Image_U is procedure Set_Image_Unsigned (V : Uns; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then P <= S'Last - Unsigned_Width_Ghost + 1, - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then P in P'Old + 1 .. S'Last - and then U_Spec.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) - and then U_Spec.Scan_Based_Number_Ghost - (S, From => P'Old + 1, To => P) - = U_Spec.Wrap_Option (V); + P : in out Natural); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Uns'Image (V) except that no leading space is stored. The caller diff --git a/gcc/ada/libgnat/s-imde128.ads b/gcc/ada/libgnat/s-imde128.ads index f353f57..03485b9 100644 --- a/gcc/ada/libgnat/s-imde128.ads +++ b/gcc/ada/libgnat/s-imde128.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_128 is subtype Int128 is Interfaces.Integer_128; - subtype Uns128 is Interfaces.Unsigned_128; - package Impl is new Image_D (Int128, Uns128); + package Impl is new Image_D (Int128); procedure Image_Decimal128 (V : Int128; diff --git a/gcc/ada/libgnat/s-imde32.ads b/gcc/ada/libgnat/s-imde32.ads index 442f343..40fd5e9 100644 --- a/gcc/ada/libgnat/s-imde32.ads +++ b/gcc/ada/libgnat/s-imde32.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_32 is subtype Int32 is Interfaces.Integer_32; - subtype Uns32 is Interfaces.Unsigned_32; - package Impl is new Image_D (Int32, Uns32); + package Impl is new Image_D (Int32); procedure Image_Decimal32 (V : Int32; diff --git a/gcc/ada/libgnat/s-imde64.ads b/gcc/ada/libgnat/s-imde64.ads index a69e02f..5264c43 100644 --- a/gcc/ada/libgnat/s-imde64.ads +++ b/gcc/ada/libgnat/s-imde64.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_64 is subtype Int64 is Interfaces.Integer_64; - subtype Uns64 is Interfaces.Unsigned_64; - package Impl is new Image_D (Int64, Uns64); + package Impl is new Image_D (Int64); procedure Image_Decimal64 (V : Int64; diff --git a/gcc/ada/libgnat/s-imfi128.ads b/gcc/ada/libgnat/s-imfi128.ads index 9bb383a..23cd059 100644 --- a/gcc/ada/libgnat/s-imfi128.ads +++ b/gcc/ada/libgnat/s-imfi128.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_128 is subtype Int128 is Interfaces.Integer_128; - subtype Uns128 is Interfaces.Unsigned_128; - package Impl is new Image_F (Int128, Uns128, Arith_128.Scaled_Divide128); + package Impl is new Image_F (Int128, Arith_128.Scaled_Divide128); procedure Image_Fixed128 (V : Int128; diff --git a/gcc/ada/libgnat/s-imfi32.ads b/gcc/ada/libgnat/s-imfi32.ads index f66b0fa..ba46e8d 100644 --- a/gcc/ada/libgnat/s-imfi32.ads +++ b/gcc/ada/libgnat/s-imfi32.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_32 is subtype Int32 is Interfaces.Integer_32; - subtype Uns32 is Interfaces.Unsigned_32; - package Impl is new Image_F (Int32, Uns32, Arith_32.Scaled_Divide32); + package Impl is new Image_F (Int32, Arith_32.Scaled_Divide32); procedure Image_Fixed32 (V : Int32; diff --git a/gcc/ada/libgnat/s-imfi64.ads b/gcc/ada/libgnat/s-imfi64.ads index ecb70ad..c7f7aa1 100644 --- a/gcc/ada/libgnat/s-imfi64.ads +++ b/gcc/ada/libgnat/s-imfi64.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_64 is subtype Int64 is Interfaces.Integer_64; - subtype Uns64 is Interfaces.Unsigned_64; - package Impl is new Image_F (Int64, Uns64, Arith_64.Scaled_Divide64); + package Impl is new Image_F (Int64, Arith_64.Scaled_Divide64); procedure Image_Fixed64 (V : Int64; diff --git a/gcc/ada/libgnat/s-imgboo.adb b/gcc/ada/libgnat/s-imgboo.adb index 436818c..c4d85bf 100644 --- a/gcc/ada/libgnat/s-imgboo.adb +++ b/gcc/ada/libgnat/s-imgboo.adb @@ -29,32 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Img_Bool with SPARK_Mode is - - -- Local lemmas - - procedure Lemma_Is_First_Non_Space_Ghost (S : String; R : Positive) with - Ghost, - Pre => R in S'Range and then S (R) /= ' ' - and then System.Val_Spec.Only_Space_Ghost (S, S'First, R - 1), - Post => System.Val_Spec.First_Non_Space_Ghost (S, S'First, S'Last) = R; - - ------------------------------------ - -- Lemma_Is_First_Non_Space_Ghost -- - ------------------------------------ - - procedure Lemma_Is_First_Non_Space_Ghost (S : String; R : Positive) is null; - ------------------- -- Image_Boolean -- ------------------- @@ -69,11 +46,9 @@ is if V then S (1 .. 4) := "TRUE"; P := 4; - Lemma_Is_First_Non_Space_Ghost (S, 1); else S (1 .. 5) := "FALSE"; P := 5; - Lemma_Is_First_Non_Space_Ghost (S, 1); end if; end Image_Boolean; diff --git a/gcc/ada/libgnat/s-imgboo.ads b/gcc/ada/libgnat/s-imgboo.ads index 9d8b1f7..af19c2e 100644 --- a/gcc/ada/libgnat/s-imgboo.ads +++ b/gcc/ada/libgnat/s-imgboo.ads @@ -34,32 +34,13 @@ -- This package provides support for ``Image`` attribute on ``Boolean``. The -- compiler performs direct calls to this unit to implement the attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Val_Spec; - package System.Img_Bool with SPARK_Mode, Preelaborate is - procedure Image_Boolean (V : Boolean; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then (if V then S'Length >= 4 else S'Length >= 5), - Post => (if V then P = 4 else P = 5) - and then System.Val_Spec.Is_Boolean_Image_Ghost (S (1 .. P), V); + P : out Natural); -- Computes Boolean'Image (``V``) and stores the result in -- ``S`` (1 .. ``P``) setting the resulting value of ``P``. The caller -- guarantees that ``S`` is long enough to hold the result, and that diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads index 1ccf173..55df149 100644 --- a/gcc/ada/libgnat/s-imgint.ads +++ b/gcc/ada/libgnat/s-imgint.ads @@ -33,33 +33,12 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types up to Size ``Integer'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_Int; -with System.Vs_Uns; package System.Img_Int with SPARK_Mode is - subtype Unsigned is Unsigned_Types.Unsigned; - - package Impl is new Image_I - (Int => Integer, - Uns => Unsigned, - U_Spec => System.Vs_Uns.Spec, - I_Spec => System.Vs_Int.Spec); + package Impl is new Image_I (Integer); procedure Image_Integer (V : Integer; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index 32be4dc..28fd563 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -33,33 +33,12 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types larger than Size ``Integer'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_LLI; -with System.Vs_LLU; package System.Img_LLI with SPARK_Mode is - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Impl is new Image_I - (Int => Long_Long_Integer, - Uns => Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec, - I_Spec => System.Vs_LLI.Spec); + package Impl is new Image_I (Long_Long_Integer); procedure Image_Long_Long_Integer (V : Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads index 47c75b0..cecbdff 100644 --- a/gcc/ada/libgnat/s-imgllli.ads +++ b/gcc/ada/libgnat/s-imgllli.ads @@ -33,33 +33,12 @@ -- signed integer types larger than Long_Long_Integer, and also for conversion -- operations required in Text_IO.Integer_IO for such types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_LLLI; -with System.Vs_LLLU; package System.Img_LLLI with SPARK_Mode is - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Impl is new Image_I - (Int => Long_Long_Long_Integer, - Uns => Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec, - I_Spec => System.Vs_LLLI.Spec); + package Impl is new Image_I (Long_Long_Long_Integer); procedure Image_Long_Long_Long_Integer (V : Long_Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads index 0dbe1f21c..e581d37 100644 --- a/gcc/ada/libgnat/s-imglllu.ads +++ b/gcc/ada/libgnat/s-imglllu.ads @@ -33,30 +33,15 @@ -- modular integer types larger than Long_Long_Unsigned, and also for -- conversion operations required in Text_IO.Modular_IO for such types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_LLLU; package System.Img_LLLU with SPARK_Mode is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - package Impl is new Image_U - (Uns => Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec); + package Impl is new Image_U (Uns => Long_Long_Long_Unsigned); procedure Image_Long_Long_Long_Unsigned (V : Long_Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads index 82d372d..729e6e8 100644 --- a/gcc/ada/libgnat/s-imgllu.ads +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -33,30 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for unsigned (modular) -- integer types larger than Size ``Unsigned'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_LLU; package System.Img_LLU with SPARK_Mode is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Impl is new Image_U - (Uns => Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec); + package Impl is new Image_U (Uns => Long_Long_Unsigned); procedure Image_Long_Long_Unsigned (V : Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads index 142591a..dbab67e 100644 --- a/gcc/ada/libgnat/s-imguns.ads +++ b/gcc/ada/libgnat/s-imguns.ads @@ -33,30 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for modular integer -- types up to size ``Unsigned'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_Uns; package System.Img_Uns with SPARK_Mode is subtype Unsigned is Unsigned_Types.Unsigned; - package Impl is new Image_U - (Uns => Unsigned, - U_Spec => System.Vs_Uns.Spec); + package Impl is new Image_U (Uns => Unsigned); procedure Image_Unsigned (V : Unsigned; diff --git a/gcc/ada/libgnat/s-spark.ads b/gcc/ada/libgnat/s-spark.ads deleted file mode 100644 index c46409f..0000000 --- a/gcc/ada/libgnat/s-spark.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This is the top level unit of the SPARK package. Its children --- contain helper functions to aid proofs. - -package System.SPARK with - SPARK_Mode, - Pure -is -end System.SPARK; diff --git a/gcc/ada/libgnat/s-spcuop.adb b/gcc/ada/libgnat/s-spcuop.adb deleted file mode 100644 index 74422ea..0000000 --- a/gcc/ada/libgnat/s-spcuop.adb +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K . C U T _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, 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. -- --- -- ------------------------------------------------------------------------------- - -package body System.SPARK.Cut_Operations with - SPARK_Mode => Off -is - - function By (Consequence, Premise : Boolean) return Boolean is - (Premise and then Consequence); - - function So (Premise, Consequence : Boolean) return Boolean is - (Premise and then Consequence); - -end System.SPARK.Cut_Operations; diff --git a/gcc/ada/libgnat/s-spcuop.ads b/gcc/ada/libgnat/s-spcuop.ads deleted file mode 100644 index 04a94a5..0000000 --- a/gcc/ada/libgnat/s-spcuop.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K . C U T _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package provides connectors used to manually help the proof of --- assertions by introducing intermediate steps. They can only be used inside --- pragmas Assert or Assert_And_Cut. - -package System.SPARK.Cut_Operations with - SPARK_Mode, - Pure, - Always_Terminates -is - - function By (Consequence, Premise : Boolean) return Boolean with - Ghost, - Global => null; - -- If A and B are two boolean expressions, proving By (A, B) requires - -- proving B, the premise, and then A assuming B, the side-condition. When - -- By (A, B) is assumed on the other hand, we only assume A. B is used - -- for the proof, but is not visible afterward. - - function So (Premise, Consequence : Boolean) return Boolean with - Ghost, - Global => null; - -- If A and B are two boolean expressions, proving So (A, B) requires - -- proving A, the premise, and then B assuming A, the side-condition. When - -- So (A, B) is assumed both A and B are assumed to be true. - -end System.SPARK.Cut_Operations; diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index 45af884..1b4b807 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -41,6 +41,7 @@ with System.Soft_Links; with System.CRTL; with System.Dwarf_Lines; with System.Exception_Traces; +with System.OS_Lib; with System.Standard_Library; with System.Traceback_Entries; with System.Strings; @@ -413,6 +414,23 @@ package body System.Traceback.Symbolic is return; end if; + -- On some platforms, we use dladdr and the dli_fname field to get the + -- pathname, but that pathname might be relative and not point to the + -- right thing in our context. That happens when the executable is + -- dynamically linked and was started through execvp; dli_fname only + -- contains the executable name passed to execvp in that case. + -- + -- Because of this, we might be about to open a file that's in fact not + -- a shared object but something completely unrelated. It's hard to + -- detect this in general, but we perform a sanity check that + -- Module_Name does not designate a directory; if it does, it's + -- definitely not a shared object. + + if System.OS_Lib.Is_Directory (Module_Name) then + Success := False; + return; + end if; + Open (Module_Name, Module.C, Success); -- If a module can't be opened just return now, we just cannot give more diff --git a/gcc/ada/libgnat/s-vaispe.adb b/gcc/ada/libgnat/s-vaispe.adb deleted file mode 100644 index 0b09f75..0000000 --- a/gcc/ada/libgnat/s-vaispe.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ I _ S P E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, 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. -- --- -- ------------------------------------------------------------------------------- - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -package body System.Value_I_Spec is - - ----------------------------------- - -- Prove_Scan_Only_Decimal_Ghost -- - ----------------------------------- - - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) is - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - pragma Assert (Str (Str'First + 1) /= ' '); - pragma Assert - (if Val < 0 then Non_Blank = Str'First - else - Str (Str'First) = ' ' - and then Non_Blank = Str'First + 1); - Minus : constant Boolean := Str (Non_Blank) = '-'; - Fst_Num : constant Positive := - (if Minus then Non_Blank + 1 else Non_Blank); - pragma Assert (Fst_Num = Str'First + 1); - Uval : constant Uns := Abs_Uns_Of_Int (Val); - - procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) - with - Pre => Minus = (Val < 0) - and then Uval = Abs_Uns_Of_Int (Val), - Post => Uns_Is_Valid_Int (Minus, Uval) - and then Is_Int_Of_Uns (Minus, Uval, Val); - -- Local proof of the unicity of the signed representation - - procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) is null; - - -- Start of processing for Prove_Scan_Only_Decimal_Ghost - - begin - Prove_Conversion_Is_Identity (Val, Uval); - pragma Assert - (U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - pragma Assert - (U_Spec.Scan_Split_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - U_Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, 10); - pragma Assert - (U_Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert (Only_Space_Ghost - (Str, U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last), Str'Last)); - pragma Assert (Is_Integer_Ghost (Str)); - pragma Assert (Is_Value_Integer_Ghost (Str, Val)); - end Prove_Scan_Only_Decimal_Ghost; - -end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-vaispe.ads b/gcc/ada/libgnat/s-vaispe.ads deleted file mode 100644 index 2e729aa..0000000 --- a/gcc/ada/libgnat/s-vaispe.ads +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ I _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides the --- specification entities using for the formal verification of the routines --- for scanning signed integer values. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; -with System.Val_Spec; use System.Val_Spec; - -generic - - type Int is range <>; - - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - -package System.Value_I_Spec with - Ghost, - SPARK_Mode, - Always_Terminates -is - pragma Preelaborate; - use all type U_Spec.Uns_Option; - - function Uns_Is_Valid_Int (Minus : Boolean; Uval : Uns) return Boolean is - (if Minus then Uval <= Uns (Int'Last) + 1 - else Uval <= Uns (Int'Last)) - with Post => True; - -- Return True if Uval (or -Uval when Minus is True) is a valid number of - -- type Int. - - function Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - return Boolean - is - (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First - elsif Minus then Val = -(Int (Uval)) - else Val = Int (Uval)) - with - Pre => Uns_Is_Valid_Int (Minus, Uval), - Post => True; - -- Return True if Uval (or -Uval when Minus is True) is equal to Val - - function Abs_Uns_Of_Int (Val : Int) return Uns is - (if Val = Int'First then Uns (Int'Last) + 1 - elsif Val < 0 then Uns (-Val) - else Uns (Val)); - -- Return the unsigned absolute value of Val - - function Slide_To_1 (Str : String) return String - with - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - (for all J in Str'First .. Str'Last => - Slide_To_1'Result (J - Str'First + 1) = ' '); - -- Slides Str so that it starts at 1 - - function Slide_If_Necessary (Str : String) return String is - (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); - -- If Str'Last = Positive'Last then slides Str so that it starts at 1 - - function Is_Integer_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); - begin - U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then U_Spec.Raw_Unsigned_No_Overflow_Ghost - (Str, Fst_Num, Str'Last) - and then - Uns_Is_Valid_Int - (Minus => Str (Non_Blank) = '-', - Uval => U_Spec.Scan_Raw_Unsigned_Ghost - (Str, Fst_Num, Str'Last)) - and then Only_Space_Ghost - (Str, U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last), Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last, - Post => True; - -- Ghost function that determines if Str has the correct format for a - -- signed number, consisting in some blank characters, an optional - -- sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Integer_Ghost (Str : String; Val : Int) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); - Uval : constant Uns := - U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); - begin - Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Val)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Integer_Ghost (Str), - Post => True; - -- Ghost function that returns True if Val is the value corresponding to - -- the signed number represented by Str. - - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then Str'Length >= 2 - and then Str (Str'First) in ' ' | '-' - and then (Str (Str'First) = '-') = (Val < 0) - and then U_Spec.Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) - and then U_Spec.Scan_Based_Number_Ghost - (Str, Str'First + 1, Str'Last) - = U_Spec.Wrap_Option (Abs_Uns_Of_Int (Val)), - Post => Is_Integer_Ghost (Slide_If_Necessary (Str)) - and then Is_Value_Integer_Ghost (Str, Val); - -- Ghost lemma used in the proof of 'Image implementation, to prove that - -- the result of Value_Integer on a decimal string is the same as the - -- signing the result of Scan_Based_Number_Ghost. - -private - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - -end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-valboo.adb b/gcc/ada/libgnat/s-valboo.adb index 8db3316..93d6fb2 100644 --- a/gcc/ada/libgnat/s-valboo.adb +++ b/gcc/ada/libgnat/s-valboo.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Val_Util; use System.Val_Util; package body System.Val_Bool @@ -55,9 +47,6 @@ is begin Normalize_String (S, F, L, To_Upper_Case => True); - pragma Assert (F = System.Val_Spec.First_Non_Space_Ghost - (S, Str'First, Str'Last)); - if S (F .. L) = "TRUE" then return True; diff --git a/gcc/ada/libgnat/s-valboo.ads b/gcc/ada/libgnat/s-valboo.ads index fdd8a3f..b2fd558 100644 --- a/gcc/ada/libgnat/s-valboo.ads +++ b/gcc/ada/libgnat/s-valboo.ads @@ -29,32 +29,12 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Val_Spec; - package System.Val_Bool with SPARK_Mode is pragma Preelaborate; - function Value_Boolean (Str : String) return Boolean - with - Pre => System.Val_Spec.Is_Boolean_Image_Ghost (Str, True) - or else System.Val_Spec.Is_Boolean_Image_Ghost (Str, False), - Post => - Value_Boolean'Result = - (Str (System.Val_Spec.First_Non_Space_Ghost - (Str, Str'First, Str'Last)) in 't' | 'T'); + function Value_Boolean (Str : String) return Boolean; -- Computes Boolean'Value (Str) end System.Val_Bool; diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads index 6045cd6..164bbfe 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Integer values for use -- in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_Uns; with System.Value_I; -with System.Vs_Int; -with System.Vs_Uns; package System.Val_Int with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_Int with SPARK_Mode is package Impl is new Value_I (Int => Integer, Uns => Unsigned, - Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned, - U_Spec => System.Vs_Uns.Spec, - Spec => System.Vs_Int.Spec); + Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned); procedure Scan_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index 7672cc5..a3b48e3 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Long_Long_Integer -- values for use in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_LLU; with System.Value_I; -with System.Vs_LLI; -with System.Vs_LLU; package System.Val_LLI with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_LLI with SPARK_Mode is package Impl is new Value_I (Int => Long_Long_Integer, Uns => Long_Long_Unsigned, - Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec, - Spec => System.Vs_LLI.Spec); + Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned); procedure Scan_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads index e2cae26..719d4f4 100644 --- a/gcc/ada/libgnat/s-valllli.ads +++ b/gcc/ada/libgnat/s-valllli.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Long_Long_Long_Integer -- values for use in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_LLLU; with System.Value_I; -with System.Vs_LLLI; -with System.Vs_LLLU; package System.Val_LLLI with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_LLLI with SPARK_Mode is package Impl is new Value_I (Int => Long_Long_Long_Integer, Uns => Long_Long_Long_Unsigned, - Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec, - Spec => System.Vs_LLLI.Spec); + Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned); procedure Scan_Long_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallllu.ads b/gcc/ada/libgnat/s-vallllu.ads index 8e57e51..50a061b 100644 --- a/gcc/ada/libgnat/s-vallllu.ads +++ b/gcc/ada/libgnat/s-vallllu.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Long_Long_Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_LLLU; package System.Val_LLLU with SPARK_Mode is pragma Preelaborate; subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - package Impl is new Value_U (Long_Long_Long_Unsigned, System.Vs_LLLU.Spec); + package Impl is new Value_U (Long_Long_Long_Unsigned); procedure Scan_Raw_Long_Long_Long_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads index a7e37fc..eeb9a25 100644 --- a/gcc/ada/libgnat/s-valllu.ads +++ b/gcc/ada/libgnat/s-valllu.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Long_Long_Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_LLU; package System.Val_LLU with SPARK_Mode is pragma Preelaborate; subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Impl is new Value_U (Long_Long_Unsigned, System.Vs_LLU.Spec); + package Impl is new Value_U (Long_Long_Unsigned); procedure Scan_Raw_Long_Long_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valspe.adb b/gcc/ada/libgnat/s-valspe.adb deleted file mode 100644 index b47e818..0000000 --- a/gcc/ada/libgnat/s-valspe.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ S P E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2023-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -package body System.Val_Spec - with SPARK_Mode -is - - --------------------------- - -- First_Non_Space_Ghost -- - --------------------------- - - function First_Non_Space_Ghost - (S : String; - From, To : Integer) return Positive - is - begin - for J in From .. To loop - if S (J) /= ' ' then - return J; - end if; - - pragma Loop_Invariant (for all K in From .. J => S (K) = ' '); - end loop; - - raise Program_Error; - end First_Non_Space_Ghost; - - ----------------------- - -- Last_Number_Ghost -- - ----------------------- - - function Last_Number_Ghost (Str : String) return Positive is - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "occurs in ghost code, not executable"); - - for J in Str'Range loop - if Str (J) not in '0' .. '9' | '_' then - return J - 1; - end if; - - pragma Loop_Invariant - (for all K in Str'First .. J => Str (K) in '0' .. '9' | '_'); - end loop; - - return Str'Last; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); - end Last_Number_Ghost; - -end System.Val_Spec; diff --git a/gcc/ada/libgnat/s-valspe.ads b/gcc/ada/libgnat/s-valspe.ads deleted file mode 100644 index fbd3ba5..0000000 --- a/gcc/ada/libgnat/s-valspe.ads +++ /dev/null @@ -1,246 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides some common --- specification functions used by the s-valxxx files. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -package System.Val_Spec with - SPARK_Mode, - Pure, - Ghost -is - function Only_Space_Ghost (S : String; From, To : Integer) return Boolean is - (for all J in From .. To => S (J) = ' ') - with - Pre => From > To or else (From >= S'First and then To <= S'Last), - Post => True; - -- Ghost function that returns True if S has only space characters from - -- index From to index To. - - function First_Non_Space_Ghost - (S : String; - From, To : Integer) return Positive - with - Pre => From in S'Range - and then To in S'Range - and then not Only_Space_Ghost (S, From, To), - Post => First_Non_Space_Ghost'Result in From .. To - and then S (First_Non_Space_Ghost'Result) /= ' ' - and then Only_Space_Ghost - (S, From, First_Non_Space_Ghost'Result - 1); - -- Ghost function that returns the index of the first non-space character - -- in S, which necessarily exists given the precondition on S. - - function Is_Boolean_Image_Ghost - (Str : String; - Val : Boolean) return Boolean - is - (not Only_Space_Ghost (Str, Str'First, Str'Last) - and then - (declare - F : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - begin - (Val - and then F <= Str'Last - 3 - and then Str (F) in 't' | 'T' - and then Str (F + 1) in 'r' | 'R' - and then Str (F + 2) in 'u' | 'U' - and then Str (F + 3) in 'e' | 'E' - and then - (if F + 3 < Str'Last then - Only_Space_Ghost (Str, F + 4, Str'Last))) - or else - (not Val - and then F <= Str'Last - 4 - and then Str (F) in 'f' | 'F' - and then Str (F + 1) in 'a' | 'A' - and then Str (F + 2) in 'l' | 'L' - and then Str (F + 3) in 's' | 'S' - and then Str (F + 4) in 'e' | 'E' - and then - (if F + 4 < Str'Last then - Only_Space_Ghost (Str, F + 5, Str'Last))))) - with - Ghost; - -- Ghost function that returns True iff Str is the image of boolean Val, - -- that is "true" or "false" in any capitalization, possibly surounded by - -- space characters. - - function Only_Number_Ghost (Str : String; From, To : Integer) return Boolean - is - (for all J in From .. To => Str (J) in '0' .. '9' | '_') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only number characters from - -- index From to index To. - - function Last_Number_Ghost (Str : String) return Positive - with - Pre => Str /= "" and then Str (Str'First) in '0' .. '9', - Post => Last_Number_Ghost'Result in Str'Range - and then (if Last_Number_Ghost'Result < Str'Last then - Str (Last_Number_Ghost'Result + 1) not in '0' .. '9' | '_') - and then Only_Number_Ghost (Str, Str'First, Last_Number_Ghost'Result); - -- Ghost function that returns the index of the last character in S that - -- is either a figure or underscore, which necessarily exists given the - -- precondition on Str. - - function Is_Natural_Format_Ghost (Str : String) return Boolean is - (Str /= "" - and then Str (Str'First) in '0' .. '9' - and then - (declare - L : constant Positive := Last_Number_Ghost (Str); - begin - Str (L) in '0' .. '9' - and then (for all J in Str'First .. L => - (if Str (J) = '_' then Str (J + 1) /= '_')))); - -- Ghost function that determines if Str has the correct format for a - -- natural number, consisting in a sequence of figures possibly separated - -- by single underscores. It may be followed by other characters. - - function Starts_As_Exponent_Format_Ghost - (Str : String; - Real : Boolean := False) return Boolean - is - (Str'Length > 1 - and then Str (Str'First) in 'E' | 'e' - and then - (declare - Plus_Sign : constant Boolean := Str (Str'First + 1) = '+'; - Minus_Sign : constant Boolean := Str (Str'First + 1) = '-'; - Sign : constant Boolean := Plus_Sign or Minus_Sign; - begin - (if Minus_Sign then Real) - and then (if Sign then Str'Length > 2) - and then - (declare - Start : constant Natural := - (if Sign then Str'First + 2 else Str'First + 1); - begin - Str (Start) in '0' .. '9'))); - -- Ghost function that determines if Str is recognized as something which - -- might be an exponent, ie. it starts with an 'e', capitalized or not, - -- followed by an optional sign which can only be '-' if we are working on - -- real numbers (Real is True), and then a digit in decimal notation. - - function Is_Opt_Exponent_Format_Ghost - (Str : String; - Real : Boolean := False) return Boolean - is - (not Starts_As_Exponent_Format_Ghost (Str, Real) - or else - (declare - Start : constant Natural := - (if Str (Str'First + 1) in '+' | '-' then Str'First + 2 - else Str'First + 1); - begin Is_Natural_Format_Ghost (Str (Start .. Str'Last)))); - -- Ghost function that determines if Str has the correct format for an - -- optional exponent, that is, either it does not start as an exponent, or - -- it is in a correct format for a natural number. - - function Scan_Natural_Ghost - (Str : String; - P : Natural; - Acc : Natural) - return Natural - with - Subprogram_Variant => (Increases => P), - Pre => Str /= "" and then Str (Str'First) in '0' .. '9' - and then Str'Last < Natural'Last - and then P in Str'First .. Last_Number_Ghost (Str) + 1; - -- Ghost function that recursively computes the natural number in Str, up - -- to the first number greater or equal to Natural'Last / 10, assuming Acc - -- has been scanned already and scanning continues at index P. - - function Scan_Exponent_Ghost - (Str : String; - Real : Boolean := False) - return Integer - is - (declare - Plus_Sign : constant Boolean := Str (Str'First + 1) = '+'; - Minus_Sign : constant Boolean := Str (Str'First + 1) = '-'; - Sign : constant Boolean := Plus_Sign or Minus_Sign; - Start : constant Natural := - (if Sign then Str'First + 2 else Str'First + 1); - Value : constant Natural := - Scan_Natural_Ghost (Str (Start .. Str'Last), Start, 0); - begin - (if Minus_Sign then -Value else Value)) - with - Pre => Str'Last < Natural'Last - and then Starts_As_Exponent_Format_Ghost (Str, Real), - Post => (if not Real then Scan_Exponent_Ghost'Result >= 0); - -- Ghost function that scans an exponent - -private - - ------------------------ - -- Scan_Natural_Ghost -- - ------------------------ - - function Scan_Natural_Ghost - (Str : String; - P : Natural; - Acc : Natural) - return Natural - is - (if P > Str'Last - or else Str (P) not in '0' .. '9' | '_' - or else Acc >= Integer'Last / 10 - then - Acc - elsif Str (P) = '_' then - Scan_Natural_Ghost (Str, P + 1, Acc) - else - (declare - Shift_Acc : constant Natural := - Acc * 10 + - (Integer'(Character'Pos (Str (P))) - - Integer'(Character'Pos ('0'))); - begin - Scan_Natural_Ghost (Str, P + 1, Shift_Acc))); - -end System.Val_Spec; diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb index 2c4fe09..53790a0 100644 --- a/gcc/ada/libgnat/s-valuei.adb +++ b/gcc/ada/libgnat/s-valuei.adb @@ -33,16 +33,6 @@ with System.Val_Util; use System.Val_Util; package body System.Value_I is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - ------------------ -- Scan_Integer -- ------------------ @@ -53,25 +43,6 @@ package body System.Value_I is Max : Integer; Res : out Int) is - procedure Prove_Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - with Ghost, - Pre => Spec.Uns_Is_Valid_Int (Minus, Uval) - and then - (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First - elsif Minus then Val = -(Int (Uval)) - else Val = Int (Uval)), - Post => Spec.Is_Int_Of_Uns (Minus, Uval, Val); - -- Unfold the definition of Is_Int_Of_Uns - - procedure Prove_Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - is null; - Uval : Uns; -- Unsigned result @@ -81,15 +52,6 @@ package body System.Value_I is Unused_Start : Positive; -- Saves location of first non-blank (not used in this case) - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all, Max) - with Ghost; - - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank) - with Ghost; - begin Scan_Sign (Str, Ptr, Max, Minus, Unused_Start); @@ -99,8 +61,6 @@ package body System.Value_I is end if; Scan_Raw_Unsigned (Str, Ptr, Max, Uval); - pragma Assert - (Uval = U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)); -- Deal with overflow cases, and also with largest negative number @@ -121,11 +81,6 @@ package body System.Value_I is else Res := Int (Uval); end if; - - Prove_Is_Int_Of_Uns - (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Res); end Scan_Integer; ------------------- @@ -141,15 +96,7 @@ package body System.Value_I is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); - procedure Prove_Is_Integer_Ghost with - Ghost, - Pre => Str'Length < Natural'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Integer_Ghost (Spec.Slide_To_1 (Str)), - Post => Spec.Is_Integer_Ghost (NT (Str)); - procedure Prove_Is_Integer_Ghost is null; begin - Prove_Is_Integer_Ghost; return Value_Integer (NT (Str)); end; @@ -159,31 +106,14 @@ package body System.Value_I is declare V : Int; P : aliased Integer := Str'First; - - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last) - with Ghost; - - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank) - with Ghost; begin - declare P_Acc : constant not null access Integer := P'Access; begin Scan_Integer (Str, P_Acc, Str'Last, V); end; - pragma Assert - (P = U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last)); - Scan_Trailing_Blanks (Str, P); - - pragma Assert - (Spec.Is_Value_Integer_Ghost (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads index 531eae1..08619c8 100644 --- a/gcc/ada/libgnat/s-valuei.ads +++ b/gcc/ada/libgnat/s-valuei.ads @@ -32,16 +32,6 @@ -- This package contains routines for scanning signed integer values for use -- in Text_IO.Integer_IO, and the Value attribute. -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Val_Spec; use System.Val_Spec; -with System.Value_I_Spec; -with System.Value_U_Spec; - generic type Int is range <>; @@ -54,13 +44,6 @@ generic Max : Integer; Res : out Uns); - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - with package Spec is new System.Value_I_Spec - (Int => Int, Uns => Uns, U_Spec => U_Spec) - with Ghost; - package System.Value_I is pragma Preelaborate; @@ -68,43 +51,7 @@ package System.Value_I is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Int) - with - Pre => Str'Last /= Positive'Last - -- Ptr.all .. Max is either an empty range, or a valid range in Str - and then (Ptr.all > Max - or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Ptr.all, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank); - begin - U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max)) - and then U_Spec.Raw_Unsigned_No_Overflow_Ghost - (Str, Fst_Num, Max) - and then Spec.Uns_Is_Valid_Int - (Minus => Str (Non_Blank) = '-', - Uval => U_Spec.Scan_Raw_Unsigned_Ghost - (Str, Fst_Num, Max))), - Post => - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Ptr.all'Old, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank); - Uval : constant Uns := - U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max); - begin - Spec.Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Res) - and then Ptr.all = U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Max)); + Res : out Int); -- This procedure scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring -- scanned extends no further than Str (Max). There are three cases for the @@ -130,14 +77,7 @@ package System.Value_I is -- special case of an all-blank string, and Ptr is unchanged, and hence -- is greater than Max as required in this case. - function Value_Integer (Str : String) return Int - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Length /= Positive'Last - and then Spec.Is_Integer_Ghost (Spec.Slide_If_Necessary (Str)), - Post => Spec.Is_Value_Integer_Ghost - (Spec.Slide_If_Necessary (Str), Value_Integer'Result), - Subprogram_Variant => (Decreases => Str'First); + function Value_Integer (Str : String) return Int; -- Used in computing X'Value (Str) where X is a signed integer type whose -- base range does not exceed the base range of Integer. Str is the string -- argument of the attribute. Constraint_Error is raised if the string is diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb index e6f1d5e..72e73a8 100644 --- a/gcc/ada/libgnat/s-valueu.adb +++ b/gcc/ada/libgnat/s-valueu.adb @@ -29,78 +29,10 @@ -- -- ------------------------------------------------------------------------------ -with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations; with System.Val_Util; use System.Val_Util; package body System.Value_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - - use type Spec.Uns_Option; - use type Spec.Split_Value_Ghost; - - -- Local lemmas - - procedure Lemma_Digit_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - with Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then P in From .. To - and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 - and then Spec.Is_Based_Format_Ghost (Str (From .. To)), - Post => - (if Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - then P <= Spec.Last_Hexa_Ghost (Str (From .. To))); - - procedure Lemma_Underscore_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - with Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then P in From .. To - and then Str (P) = '_' - and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 - and then Spec.Is_Based_Format_Ghost (Str (From .. To)), - Post => P + 1 <= Spec.Last_Hexa_Ghost (Str (From .. To)) - and then Str (P + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Digit_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - is null; - - procedure Lemma_Underscore_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - is null; - ----------------------- -- Scan_Raw_Unsigned -- ----------------------- @@ -132,36 +64,6 @@ package body System.Value_U is Digit : Uns; -- Digit value - Ptr_Old : constant Integer := Ptr.all - with Ghost; - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (Ptr.all .. Max)) - with Ghost; - Init_Val : constant Spec.Uns_Option := - Spec.Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init) - with Ghost; - Starts_As_Based : constant Boolean := - Spec.Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Max) - with Ghost; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Spec.Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Max)) - else Last_Num_Init) - with Ghost; - Is_Based : constant Boolean := - Spec.Raw_Unsigned_Is_Based_Ghost - (Str, Last_Num_Init, Last_Num_Based, Max) - with Ghost; - Based_Val : constant Spec.Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Spec.Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val) - with Ghost; - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1) - with Ghost; - begin -- We do not tolerate strings with Str'Last = Positive'Last @@ -171,7 +73,6 @@ package body System.Value_U is end if; P := Ptr.all; - Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init); Uval := Character'Pos (Str (P)) - Character'Pos ('0'); pragma Assert (Str (P) in '0' .. '9'); P := P + 1; @@ -189,14 +90,6 @@ package body System.Value_U is begin -- Loop through decimal digits loop - pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Init + 1); - pragma Loop_Invariant - (if Overflow then Init_Val.Overflow); - pragma Loop_Invariant - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Init, Acc => Uval)); - exit when P > Max; Digit := Character'Pos (Str (P)) - Character'Pos ('0'); @@ -205,8 +98,6 @@ package body System.Value_U is if Digit > 9 then if Str (P) = '_' then - Spec.Lemma_Scan_Based_Number_Ghost_Underscore - (Str, P, Last_Num_Init, Acc => Uval); Scan_Underscore (Str, P, Ptr, Max, False); else exit; @@ -215,55 +106,23 @@ package body System.Value_U is -- Accumulate result, checking for overflow else - pragma Assert - (By - (Str (P) in '0' .. '9', - By - (Character'Pos (Str (P)) >= Character'Pos ('0'), - Uns '(Character'Pos (Str (P))) >= - Character'Pos ('0')))); - Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str, P, Last_Num_Init, Acc => Uval); - Spec.Lemma_Scan_Based_Number_Ghost_Overflow - (Str, P, Last_Num_Init, Acc => Uval); - if Uval <= Umax then Uval := 10 * Uval + Digit; - pragma Assert - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Init, Acc => Uval)); - elsif Uval > Umax10 then Overflow := True; - else Uval := 10 * Uval + Digit; if Uval < Umax10 then Overflow := True; end if; - pragma Assert - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Init, Acc => Uval)); - end if; P := P + 1; end if; end loop; - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Init, Acc => Uval); end; - pragma Assert_And_Cut - (By - (P = Last_Num_Init + 1, - P > Max or else Str (P) not in '_' | '0' .. '9') - and then Overflow = Init_Val.Overflow - and then (if not Overflow then Init_Val.Value = Uval)); - Ptr.all := P; -- Deal with based case. We recognize either the standard '#' or the @@ -295,10 +154,6 @@ package body System.Value_U is -- Numbers bigger than UmaxB overflow if multiplied by base begin - pragma Assert - (if Str (P) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' - then Spec.Is_Based_Format_Ghost (Str (P .. Max))); - -- Loop to scan out based integer value loop @@ -321,49 +176,11 @@ package body System.Value_U is -- already stored in Ptr.all. else - pragma Assert - (By - (Spec.Only_Hexa_Ghost (Str, P, Last_Num_Based), - P > Last_Num_Init + 1 - and Spec.Only_Hexa_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based))); - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Based, Base, Uval); Uval := Base; Base := 10; - pragma Assert (Ptr.all = Last_Num_Init + 1); - pragma Assert - (if Starts_As_Based - then By - (P = Last_Num_Based + 1, - P <= Last_Num_Based + 1 - and Str (P) not in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_')); - pragma Assert (not Is_Based); - pragma Assert (if not Overflow then Uval = Init_Val.Value); exit; end if; - pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Based); - pragma Loop_Invariant - (Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then Digit = Spec.Hexa_To_Unsigned_Ghost (Str (P))); - pragma Loop_Invariant - (if Overflow'Loop_Entry then Overflow); - pragma Loop_Invariant - (if Overflow then - (Overflow'Loop_Entry or else Based_Val.Overflow)); - pragma Loop_Invariant - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Based, Base, Uval)); - pragma Loop_Invariant (Ptr.all = Last_Num_Init + 1); - - Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str, P, Last_Num_Based, Base, Uval); - Spec.Lemma_Scan_Based_Number_Ghost_Overflow - (Str, P, Last_Num_Based, Base, Uval); - -- If digit is too large, just signal overflow and continue. -- The idea here is to keep scanning as long as the input is -- syntactically valid, even if we have detected overflow @@ -375,24 +192,14 @@ package body System.Value_U is elsif Uval <= Umax then Uval := Base * Uval + Digit; - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Based, Base, Uval)); - elsif Uval > UmaxB then Overflow := True; - else Uval := Base * Uval + Digit; if Uval < UmaxB then Overflow := True; end if; - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Based, Base, Uval)); end if; -- If at end of string with no base char, not a based number @@ -411,86 +218,22 @@ package body System.Value_U is if Str (P) = Base_Char then Ptr.all := P + 1; - pragma Assert (P = Last_Num_Based + 1); - pragma Assert (Ptr.all = Last_Num_Based + 2); - pragma Assert - (By - (Is_Based, - So - (Starts_As_Based, - So - (Last_Num_Based < Max, - Str (Last_Num_Based + 1) = Base_Char - and Base_Char = Str (Last_Num_Init + 1))))); - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Based, Base, Uval); exit; -- Deal with underscore elsif Str (P) = '_' then - Lemma_Underscore_Not_Last (Str, P, Last_Num_Init + 2, Max); - Spec.Lemma_Scan_Based_Number_Ghost_Underscore - (Str, P, Last_Num_Based, Base, Uval); Scan_Underscore (Str, P, Ptr, Max, True); - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Based, Base, Uval)); - pragma Assert (Str (P) not in '_' | Base_Char); end if; - - Lemma_Digit_Not_Last (Str, P, Last_Num_Init + 2, Max); - pragma Assert (Str (P) not in '_' | Base_Char); end loop; end; - pragma Assert - (if Starts_As_Based then P = Last_Num_Based + 1 - else P = Last_Num_Init + 2); - pragma Assert - (By - (Overflow /= Spec.Scan_Split_No_Overflow_Ghost - (Str, Ptr_Old, Max), - So - (Last_Num_Init < Max - 1 - and then Str (Last_Num_Init + 1) in '#' | ':', - Overflow = - (Init_Val.Overflow - or else Init_Val.Value not in 2 .. 16 - or else (Starts_As_Based and Based_Val.Overflow))))); end if; - pragma Assert_And_Cut - (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max) - and then Ptr.all = First_Exp - and then Base in 2 .. 16 - and then - (if not Overflow then - (if Is_Based then Base = Init_Val.Value else Base = 10)) - and then - (if not Overflow then - (if Is_Based then Uval = Based_Val.Value - else Uval = Init_Val.Value))); - -- Come here with scanned unsigned value in Uval. The only remaining -- required step is to deal with exponent if one is present. Scan_Exponent (Str, Ptr, Max, Expon); - pragma Assert - (By - (Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max), - Ptr.all = - (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. Max)) - then First_Exp - elsif Str (First_Exp + 1) in '-' | '+' then - Last_Number_Ghost (Str (First_Exp + 2 .. Max)) + 1 - else Last_Number_Ghost (Str (First_Exp + 1 .. Max)) + 1))); - pragma Assert - (if not Overflow - then Spec.Scan_Split_Value_Ghost (Str, Ptr_Old, Max) = - (Uval, Base, Expon)); - if Expon /= 0 and then Uval /= 0 then -- For non-zero value, scale by exponent value. No need to do this @@ -500,66 +243,22 @@ package body System.Value_U is declare UmaxB : constant Uns := Uns'Last / Base; -- Numbers bigger than UmaxB overflow if multiplied by base - - Res_Val : constant Spec.Uns_Option := - Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) - with Ghost; begin for J in 1 .. Expon loop - pragma Loop_Invariant - (if Overflow'Loop_Entry then Overflow); - pragma Loop_Invariant - (if Overflow - then Overflow'Loop_Entry or else Res_Val.Overflow); - pragma Loop_Invariant (Uval /= 0); - pragma Loop_Invariant - (if not Overflow - then Res_Val = Spec.Exponent_Unsigned_Ghost - (Uval, Expon - J + 1, Base)); - - pragma Assert - ((Uval > UmaxB) = Spec.Scan_Overflows_Ghost (0, Base, Uval)); - if Uval > UmaxB then - Spec.Lemma_Exponent_Unsigned_Ghost_Overflow - (Uval, Expon - J + 1, Base); Overflow := True; exit; end if; - Spec.Lemma_Exponent_Unsigned_Ghost_Step - (Uval, Expon - J + 1, Base); - Uval := Uval * Base; end loop; - Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, Base); - - pragma Assert - (Overflow /= - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); - pragma Assert (if not Overflow then Res_Val = (False, Uval)); end; end if; - Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, Expon, Base); - pragma Assert - (if Expon = 0 or else Uval = 0 then - Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) = (False, Uval)); - pragma Assert - (Overflow /= - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); - pragma Assert - (if not Overflow then - Uval = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); -- Return result, dealing with overflow if Overflow then Bad_Value (Str); - pragma Annotate - (GNATprove, Intentional, - "call to nonreturning subprogram might be executed", - "it is expected that Constraint_Error is raised in case of" - & " overflow"); else Res := Uval; end if; @@ -608,15 +307,7 @@ package body System.Value_U is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); - procedure Prove_Is_Unsigned_Ghost with - Ghost, - Pre => Str'Length < Natural'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Unsigned_Ghost (Spec.Slide_To_1 (Str)), - Post => Spec.Is_Unsigned_Ghost (NT (Str)); - procedure Prove_Is_Unsigned_Ghost is null; begin - Prove_Is_Unsigned_Ghost; return Value_Unsigned (NT (Str)); end; @@ -626,12 +317,6 @@ package body System.Value_U is declare V : Uns; P : aliased Integer := Str'First; - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last) - with Ghost; - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank) - with Ghost; begin declare P_Acc : constant not null access Integer := P'Access; @@ -639,16 +324,7 @@ package body System.Value_U is Scan_Unsigned (Str, P_Acc, Str'Last, V); end; - pragma Assert - (P = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert - (V = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)); - Scan_Trailing_Blanks (Str, P); - - pragma Assert - (Spec.Is_Value_Unsigned_Ghost - (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads index 92e3ffe..0dc3399 100644 --- a/gcc/ada/libgnat/s-valueu.ads +++ b/gcc/ada/libgnat/s-valueu.ads @@ -32,29 +32,8 @@ -- This package contains routines for scanning modular Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; -with System.Val_Spec; use System.Val_Spec; - generic - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - package System.Value_U is pragma Preelaborate; @@ -62,15 +41,7 @@ package System.Value_U is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Uns) - with Pre => Str'Last /= Positive'Last - and then Ptr.all in Str'Range - and then Max in Ptr.all .. Str'Last - and then Spec.Is_Raw_Unsigned_Format_Ghost (Str (Ptr.all .. Max)), - Post => Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr.all'Old, Max) - and Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr.all'Old, Max) - and Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr.all'Old, Max); - + Res : out Uns); -- This function scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring -- scanned extends no further than Str (Max). Note: this does not scan @@ -145,45 +116,14 @@ package System.Value_U is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Uns) - with Pre => Str'Last /= Positive'Last - and then Ptr.all in Str'Range - and then Max in Ptr.all .. Str'Last - and then not Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))), - Post => - (declare - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Max) - and then Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max) - and then Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); - + Res : out Uns); -- Same as Scan_Raw_Unsigned, except scans optional leading -- blanks, and an optional leading plus sign. -- -- Note: if a minus sign is present, Constraint_Error will be raised. -- Note: trailing blanks are not scanned. - function Value_Unsigned - (Str : String) return Uns - with Pre => Str'Length /= Positive'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Unsigned_Ghost (Spec.Slide_If_Necessary (Str)), - Post => - Spec.Is_Value_Unsigned_Ghost - (Spec.Slide_If_Necessary (Str), Value_Unsigned'Result), - Subprogram_Variant => (Decreases => Str'First); + function Value_Unsigned (Str : String) return Uns; -- Used in computing X'Value (Str) where X is a modular integer type whose -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str -- is the string argument of the attribute. Constraint_Error is raised if diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads index 8bbb7fb..a015c12 100644 --- a/gcc/ada/libgnat/s-valuns.ads +++ b/gcc/ada/libgnat/s-valuns.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_Uns; package System.Val_Uns with SPARK_Mode is pragma Preelaborate; subtype Unsigned is Unsigned_Types.Unsigned; - package Impl is new Value_U (Unsigned, System.Vs_Uns.Spec); + package Impl is new Value_U (Unsigned); procedure Scan_Raw_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb index a2b79f1..6332137 100644 --- a/gcc/ada/libgnat/s-valuti.adb +++ b/gcc/ada/libgnat/s-valuti.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Case_Util; use System.Case_Util; package body System.Val_Util @@ -48,12 +40,11 @@ is --------------- procedure Bad_Value (S : String) is - pragma Annotate (GNATprove, Intentional, "exception might be raised", - "Intentional exception from Bad_Value"); begin -- Bad_Value might be called with very long strings allocated on the -- heap. Limit the size of the message so that we avoid creating a -- Storage_Error during error handling. + if S'Length > 127 then raise Constraint_Error with "bad input for 'Value: """ & S (S'First .. S'First + 127) & "..."""; @@ -69,8 +60,7 @@ is procedure Normalize_String (S : in out String; F, L : out Integer; - To_Upper_Case : Boolean) - is + To_Upper_Case : Boolean) is begin F := S'First; L := S'Last; @@ -84,9 +74,6 @@ is -- Scan for leading spaces while F < L and then S (F) = ' ' loop - pragma Loop_Invariant (F in S'First .. L - 1); - pragma Loop_Invariant (for all J in S'First .. F => S (J) = ' '); - pragma Loop_Variant (Increases => F); F := F + 1; end loop; @@ -101,9 +88,6 @@ is -- Scan for trailing spaces while S (L) = ' ' loop - pragma Loop_Invariant (L in F + 1 .. S'Last); - pragma Loop_Invariant (for all J in L .. S'Last => S (J) = ' '); - pragma Loop_Variant (Decreases => L); L := L - 1; end loop; @@ -112,8 +96,6 @@ is if To_Upper_Case and then S (F) /= ''' then for J in F .. L loop S (J) := To_Upper (S (J)); - pragma Loop_Invariant - (for all K in F .. J => S (K) = To_Upper (S'Loop_Entry (K))); end loop; end if; end Normalize_String; @@ -185,40 +167,23 @@ is X := 0; - declare - Rest : constant String := Str (P .. Max) with Ghost; - Last : constant Natural := Sp.Last_Number_Ghost (Rest) with Ghost; - - begin - pragma Assert (Sp.Is_Natural_Format_Ghost (Rest)); - - loop - pragma Assert (Str (P) in '0' .. '9'); + loop + pragma Assert (Str (P) in '0' .. '9'); - if X < (Integer'Last / 10) then - X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); - end if; - - pragma Loop_Invariant (X >= 0); - pragma Loop_Invariant (P in Rest'First .. Last); - pragma Loop_Invariant (Str (P) in '0' .. '9'); - pragma Loop_Invariant - (Sp.Scan_Natural_Ghost (Rest, Rest'First, 0) - = Sp.Scan_Natural_Ghost (Rest, P + 1, X)); - - P := P + 1; + if X < (Integer'Last / 10) then + X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); + end if; - exit when P > Max; + P := P + 1; - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit when Str (P) not in '0' .. '9'; - end if; - end loop; + exit when P > Max; - pragma Assert (P = Last + 1); - end; + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit when Str (P) not in '0' .. '9'; + end if; + end loop; if M then X := -X; @@ -250,12 +215,6 @@ is while Str (P) = ' ' loop P := P + 1; - pragma Loop_Invariant (Ptr.all = Ptr.all'Loop_Entry); - pragma Loop_Invariant (P in Ptr.all .. Max); - pragma Loop_Invariant (for some J in P .. Max => Str (J) /= ' '); - pragma Loop_Invariant - (for all J in Ptr.all .. P - 1 => Str (J) = ' '); - if P > Max then Ptr.all := P; Bad_Value (Str); @@ -264,8 +223,6 @@ is Start := P; - pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max)); - -- Skip past an initial plus sign if Str (P) = '+' then @@ -292,7 +249,6 @@ is Start : out Positive) is P : Integer := Ptr.all; - begin -- Deal with case of null string (all blanks). As per spec, we raise -- constraint error, with Ptr unchanged, and thus > Max. @@ -306,12 +262,6 @@ is while Str (P) = ' ' loop P := P + 1; - pragma Loop_Invariant (Ptr.all = Ptr.all'Loop_Entry); - pragma Loop_Invariant (P in Ptr.all .. Max); - pragma Loop_Invariant (for some J in P .. Max => Str (J) /= ' '); - pragma Loop_Invariant - (for all J in Ptr.all .. P - 1 => Str (J) = ' '); - if P > Max then Ptr.all := P; Bad_Value (Str); @@ -320,8 +270,6 @@ is Start := P; - pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max)); - -- Remember an initial minus sign if Str (P) = '-' then @@ -361,8 +309,6 @@ is if Str (J) /= ' ' then Bad_Value (Str); end if; - - pragma Loop_Invariant (for all K in P .. J => Str (K) = ' '); end loop; end Scan_Trailing_Blanks; @@ -378,7 +324,6 @@ is Ext : Boolean) is C : Character; - begin P := P + 1; diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 8720c41..4a299ca 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -31,59 +31,16 @@ -- This package provides some common utilities used by the s-valxxx files --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Case_Util; -with System.Val_Spec; - package System.Val_Util with SPARK_Mode, Pure is - pragma Unevaluated_Use_Of_Old (Allow); - - package Sp renames System.Val_Spec; - - procedure Bad_Value (S : String) - with - Always_Terminates, - Depends => (null => S), - Exceptional_Cases => (others => Standard.False); - pragma No_Return (Bad_Value); + procedure Bad_Value (S : String) with No_Return; -- Raises constraint error with message: bad input for 'Value: "xxx" procedure Normalize_String (S : in out String; F, L : out Integer; - To_Upper_Case : Boolean) - with - Post => (if Sp.Only_Space_Ghost (S'Old, S'First, S'Last) then - F > L - else - F >= S'First - and then L <= S'Last - and then F <= L - and then Sp.Only_Space_Ghost (S'Old, S'First, F - 1) - and then S'Old (F) /= ' ' - and then S'Old (L) /= ' ' - and then - (if L < S'Last then - Sp.Only_Space_Ghost (S'Old, L + 1, S'Last)) - and then - (if To_Upper_Case and then S'Old (F) /= ''' then - (for all J in S'Range => - (if J in F .. L then - S (J) = System.Case_Util.To_Upper (S'Old (J)) - else - S (J) = S'Old (J))))); + To_Upper_Case : Boolean); -- This procedure scans the string S setting F to be the index of the first -- non-blank character of S and L to be the index of the last non-blank -- character of S. If To_Upper_Case is True and S does not represent a @@ -96,27 +53,7 @@ is Ptr : not null access Integer; Max : Integer; Minus : out Boolean; - Start : out Positive) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Sp.Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all, Max); - begin - (if Str (F) in '+' | '-' then - F <= Max - 1 and then Str (F + 1) /= ' ')), - Post => - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - begin - Minus = (Str (F) = '-') - and then Ptr.all = (if Str (F) in '+' | '-' then F + 1 else F) - and then Start = F); + Start : out Positive); -- The Str, Ptr, Max parameters are as for the scan routines (Str is the -- string to be scanned starting at Ptr.all, and Max is the index of the -- last character in the string). Scan_Sign first scans out any initial @@ -140,26 +77,7 @@ is (Str : String; Ptr : not null access Integer; Max : Integer; - Start : out Positive) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Sp.Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all, Max); - begin - (if Str (F) = '+' then - F <= Max - 1 and then Str (F + 1) /= ' ')), - Post => - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - begin - Ptr.all = (if Str (F) = '+' then F + 1 else F) - and then Start = F); + Start : out Positive); -- Same as Scan_Sign, but allows only plus, not minus. This is used for -- modular types. @@ -168,22 +86,7 @@ is Ptr : not null access Integer; Max : Integer; Exp : out Integer; - Real : Boolean := False) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then Max < Natural'Last - and then Sp.Is_Opt_Exponent_Format_Ghost (Str (Ptr.all .. Max), Real), - Post => - (if Sp.Starts_As_Exponent_Format_Ghost (Str (Ptr.all'Old .. Max), Real) - then Exp = Sp.Scan_Exponent_Ghost (Str (Ptr.all'Old .. Max), Real) - and then - (if Str (Ptr.all'Old + 1) in '-' | '+' then - Ptr.all = Sp.Last_Number_Ghost (Str (Ptr.all'Old + 2 .. Max)) + 1 - else - Ptr.all = Sp.Last_Number_Ghost (Str (Ptr.all'Old + 1 .. Max)) + 1) - else Exp = 0 and Ptr.all = Ptr.all'Old); + Real : Boolean := False); -- Called to scan a possible exponent. Str, Ptr, Max are as described above -- for Scan_Sign. If Ptr.all < Max and Str (Ptr.all) = 'E' or 'e', then an -- exponent is scanned out, with the exponent value returned in Exp, and @@ -198,35 +101,16 @@ is -- This routine must not be called with Str'Last = Positive'Last. There is -- no check for this case, the caller must ensure this condition is met. - procedure Scan_Trailing_Blanks (Str : String; P : Positive) - with - Pre => P >= Str'First - and then Sp.Only_Space_Ghost (Str, P, Str'Last); + procedure Scan_Trailing_Blanks (Str : String; P : Positive); -- Checks that the remainder of the field Str (P .. Str'Last) is all -- blanks. Raises Constraint_Error if a non-blank character is found. - pragma Warnings - (GNATprove, Off, """Ptr"" is not modified", - Reason => "Ptr is actually modified when raising an exception"); procedure Scan_Underscore (Str : String; P : in out Natural; Ptr : not null access Integer; Max : Integer; - Ext : Boolean) - with - Pre => P in Str'Range - and then Str (P) = '_' - and then Max in Str'Range - and then P < Max - and then - (if Ext then - Str (P + 1) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' - else - Str (P + 1) in '0' .. '9'), - Post => - P = P'Old + 1 - and then Ptr.all'Old = Ptr.all; + Ext : Boolean); -- Called if an underscore is encountered while scanning digits. Str (P) -- contains the underscore. Ptr is the pointer to be returned to the -- ultimate caller of the scan routine, Max is the maximum subscript in @@ -237,6 +121,5 @@ is -- -- This routine must not be called with Str'Last = Positive'Last. There is -- no check for this case, the caller must ensure this condition is met. - pragma Warnings (GNATprove, On, """Ptr"" is not modified"); end System.Val_Util; diff --git a/gcc/ada/libgnat/s-vauspe.adb b/gcc/ada/libgnat/s-vauspe.adb deleted file mode 100644 index a350a56..0000000 --- a/gcc/ada/libgnat/s-vauspe.adb +++ /dev/null @@ -1,203 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ U _ S P E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, 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. -- --- -- ------------------------------------------------------------------------------- - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -package body System.Value_U_Spec with SPARK_Mode is - - ----------------------------- - -- Exponent_Unsigned_Ghost -- - ----------------------------- - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - is - (if Exp = 0 or Value = 0 then (Overflow => False, Value => Value) - elsif Scan_Overflows_Ghost (0, Base, Value) then (Overflow => True) - else Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); - - --------------------- - -- Last_Hexa_Ghost -- - --------------------- - - function Last_Hexa_Ghost (Str : String) return Positive is - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "occurs in ghost code, not executable"); - - for J in Str'Range loop - if Str (J) not in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' then - return J - 1; - end if; - - pragma Loop_Invariant - (for all K in Str'First .. J => - Str (K) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_'); - end loop; - - return Str'Last; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); - end Last_Hexa_Ghost; - - ----------------------------- - -- Lemmas with null bodies -- - ----------------------------- - - procedure Lemma_Scan_Based_Number_Ghost_Base - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Underscore - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Overflow - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Step - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Base - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Overflow - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Step - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - -------------------------------------- - -- Prove_Scan_Based_Number_Ghost_Eq -- - -------------------------------------- - - procedure Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is - begin - if From > To then - null; - elsif Str1 (From) = '_' then - Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2, From + 1, To, Base, Acc); - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str1 (From)), Base, Acc) - then - null; - else - Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str1 (From))); - end if; - end Prove_Scan_Based_Number_Ghost_Eq; - - ----------------------------------- - -- Prove_Scan_Only_Decimal_Ghost -- - ----------------------------------- - - procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - is - pragma Assert (Str (Str'First + 1) /= ' '); - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - pragma Assert (Non_Blank = Str'First + 1); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - pragma Assert (Fst_Num = Str'First + 1); - begin - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - pragma Assert - (Scan_Split_No_Overflow_Ghost (Str, Str'First + 1, Str'Last)); - pragma Assert - ((Val, 10, 0) = Scan_Split_Value_Ghost (Str, Str'First + 1, Str'Last)); - pragma Assert - (Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert (Val = Exponent_Unsigned_Ghost (Val, 0, 10).Value); - pragma Assert (Is_Unsigned_Ghost (Str)); - pragma Assert (Is_Value_Unsigned_Ghost (Str, Val)); - end Prove_Scan_Only_Decimal_Ghost; - - ----------------------------- - -- Scan_Based_Number_Ghost -- - ----------------------------- - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - is - (if From > To then (Overflow => False, Value => Acc) - elsif Str (From) = '_' - then Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc) - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then (Overflow => True) - else Scan_Based_Number_Ghost - (Str, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); - -end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-vauspe.ads b/gcc/ada/libgnat/s-vauspe.ads deleted file mode 100644 index 5dbb57d..0000000 --- a/gcc/ada/libgnat/s-vauspe.ads +++ /dev/null @@ -1,629 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ U _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides the --- specification entities using for the formal verification of the routines --- for scanning modular unsigned integer values. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Val_Spec; use System.Val_Spec; - -generic - - type Uns is mod <>; - -package System.Value_U_Spec with - Ghost, - SPARK_Mode, - Always_Terminates -is - pragma Preelaborate; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Uns'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - pragma Annotate (Gnatcheck, Exempt_On, "Discriminated_Records", - "variant record only used in proof code"); - type Uns_Option (Overflow : Boolean := False) is record - case Overflow is - when True => - null; - when False => - Value : Uns := 0; - end case; - end record; - pragma Annotate (Gnatcheck, Exempt_Off, "Discriminated_Records"); - - function Wrap_Option (Value : Uns) return Uns_Option is - (Overflow => False, Value => Value); - - function Only_Decimal_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (for all J in From .. To => Str (J) in '0' .. '9') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only decimal characters - -- from index From to index To. - - function Only_Hexa_Ghost (Str : String; From, To : Integer) return Boolean - is - (for all J in From .. To => - Str (J) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only hexadecimal characters - -- from index From to index To. - - function Last_Hexa_Ghost (Str : String) return Positive - with - Pre => Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', - Post => Last_Hexa_Ghost'Result in Str'Range - and then (if Last_Hexa_Ghost'Result < Str'Last then - Str (Last_Hexa_Ghost'Result + 1) not in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - and then Only_Hexa_Ghost (Str, Str'First, Last_Hexa_Ghost'Result); - -- Ghost function that returns the index of the last character in S that - -- is either an hexadecimal digit or an underscore, which necessarily - -- exists given the precondition on Str. - - function Is_Based_Format_Ghost (Str : String) return Boolean - is - (Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then - (declare - L : constant Positive := Last_Hexa_Ghost (Str); - begin - Str (L) /= '_' - and then (for all J in Str'First .. L => - (if Str (J) = '_' then Str (J + 1) /= '_')))); - -- Ghost function that determines if Str has the correct format for a - -- based number, consisting in a sequence of hexadecimal digits possibly - -- separated by single underscores. It may be followed by other characters. - - function Hexa_To_Unsigned_Ghost (X : Character) return Uns is - (case X is - when '0' .. '9' => Character'Pos (X) - Character'Pos ('0'), - when 'a' .. 'f' => Character'Pos (X) - Character'Pos ('a') + 10, - when 'A' .. 'F' => Character'Pos (X) - Character'Pos ('A') + 10, - when others => raise Program_Error) - with - Pre => X in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - -- Ghost function that computes the value corresponding to an hexadecimal - -- digit. - - function Scan_Overflows_Ghost - (Digit : Uns; - Base : Uns; - Acc : Uns) return Boolean - is - (Digit >= Base - or else Acc > Uns'Last / Base - or else Uns'Last - Digit < Base * Acc); - -- Ghost function which returns True if Digit + Base * Acc overflows or - -- Digit is greater than Base, as this is used by the algorithm for the - -- test of overflow. - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - with - Subprogram_Variant => (Increases => From), - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To); - -- Ghost function that recursively computes the based number in Str, - -- assuming Acc has been scanned already and scanning continues at index - -- From. - - -- Lemmas unfolding the recursive definition of Scan_Based_Number_Ghost - - procedure Lemma_Scan_Based_Number_Ghost_Base - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From > To - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - (Overflow => False, Value => Acc)); - -- Base case: Scan_Based_Number_Ghost returns Acc if From is bigger than To - - procedure Lemma_Scan_Based_Number_Ghost_Underscore - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To and then Str (From) = '_' - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc)); - -- Underscore case: underscores are ignored while scanning - - procedure Lemma_Scan_Based_Number_Ghost_Overflow - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To - and then Str (From) /= '_' - and then Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - (Overflow => True)); - -- Overflow case: scanning a digit which causes an overflow - - procedure Lemma_Scan_Based_Number_Ghost_Step - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To - and then Str (From) /= '_' - and then not Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - Scan_Based_Number_Ghost - (Str, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); - -- Normal case: scanning a digit without overflows - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - with - Subprogram_Variant => (Decreases => Exp); - -- Ghost function that recursively computes Value * Base ** Exp - - -- Lemmas unfolding the recursive definition of Exponent_Unsigned_Ghost - - procedure Lemma_Exponent_Unsigned_Ghost_Base - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp = 0 or Value = 0 - then Exponent_Unsigned_Ghost (Value, Exp, Base) = - (Overflow => False, Value => Value)); - -- Base case: Exponent_Unsigned_Ghost returns 0 if Value or Exp is 0 - - procedure Lemma_Exponent_Unsigned_Ghost_Overflow - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp /= 0 - and then Value /= 0 - and then Scan_Overflows_Ghost (0, Base, Value) - then Exponent_Unsigned_Ghost (Value, Exp, Base) = (Overflow => True)); - -- Overflow case: the next multiplication overflows - - procedure Lemma_Exponent_Unsigned_Ghost_Step - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp /= 0 - and then Value /= 0 - and then not Scan_Overflows_Ghost (0, Base, Value) - then Exponent_Unsigned_Ghost (Value, Exp, Base) = - Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); - -- Normal case: exponentiation without overflows - - function Raw_Unsigned_Starts_As_Based_Ghost - (Str : String; - Last_Num_Init, To : Integer) - return Boolean - is - (Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F') - with Ghost, - Pre => Last_Num_Init in Str'Range - and then To in Str'Range; - -- Return True if Str starts as a based number - - function Raw_Unsigned_Is_Based_Ghost - (Str : String; - Last_Num_Init : Integer; - Last_Num_Based : Integer; - To : Integer) - return Boolean - is - (Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To) - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1)) - with Ghost, - Pre => Last_Num_Init in Str'Range - and then Last_Num_Based in Last_Num_Init .. Str'Last - and then To in Str'Range; - -- Return True if Str is a based number - - function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is - (Is_Natural_Format_Ghost (Str) - and then - (declare - Last_Num_Init : constant Integer := Last_Number_Ghost (Str); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Str'Last); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost - (Str, Last_Num_Init, Last_Num_Based, Str'Last); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if Starts_As_Based then - Is_Based_Format_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - and then Last_Num_Based < Str'Last) - and then Is_Opt_Exponent_Format_Ghost - (Str (First_Exp .. Str'Last)))) - with - Pre => Str'Last /= Positive'Last; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number without a sign character. - -- It is a natural number in base 10, optionally followed by a based - -- number surrounded by delimiters # or :, optionally followed by an - -- exponent part. - - type Split_Value_Ghost is record - Value : Uns; - Base : Uns; - Expon : Natural; - end record; - - function Scan_Split_No_Overflow_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - begin - not Init_Val.Overflow - and then - (Last_Num_Init >= To - 1 - or else Str (Last_Num_Init + 1) not in '#' | ':' - or else Init_Val.Value in 2 .. 16) - and then - (not Starts_As_Based - or else not Based_Val.Overflow)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9'; - -- Ghost function that determines if an overflow might occur while scanning - -- the representation of an unsigned number. The computation overflows if - -- either: - -- * The computation of the decimal part overflows, - -- * The decimal part is followed by a valid delimiter for a based - -- part, and the number corresponding to the base is not a valid base, - -- or - -- * The computation of the based part overflows. - - pragma Warnings (Off, "constant * is not referenced"); - function Scan_Split_Value_Ghost - (Str : String; - From, To : Integer) - return Split_Value_Ghost - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - Expon : constant Natural := - (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then Scan_Exponent_Ghost (Str (First_Exp .. To)) - else 0); - Base : constant Uns := - (if Is_Based then Init_Val.Value else 10); - Value : constant Uns := - (if Is_Based then Based_Val.Value else Init_Val.Value); - begin - (Value => Value, Base => Base, Expon => Expon)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' - and then Scan_Split_No_Overflow_Ghost (Str, From, To); - -- Ghost function that scans an unsigned number without a sign character - -- and return a record containing the values scanned for its value, its - -- base, and its exponent. - pragma Warnings (On, "constant * is not referenced"); - - function Raw_Unsigned_No_Overflow_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (Scan_Split_No_Overflow_Ghost (Str, From, To) - and then - (declare - Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost - (Str, From, To); - begin - not Exponent_Unsigned_Ghost - (Val.Value, Val.Expon, Val.Base).Overflow)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9'; - -- Ghost function that determines if the computation of the unsigned number - -- represented by Str will overflow. The computation overflows if either: - -- * The scan of the string overflows, or - -- * The computation of the exponentiation overflows. - - function Scan_Raw_Unsigned_Ghost - (Str : String; - From, To : Integer) - return Uns - is - (declare - Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost - (Str, From, To); - begin - Exponent_Unsigned_Ghost (Val.Value, Val.Expon, Val.Base).Value) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' - and then Raw_Unsigned_No_Overflow_Ghost (Str, From, To); - -- Ghost function that scans an unsigned number without a sign character - - function Raw_Unsigned_Last_Ghost - (Str : String; - From, To : Integer) - return Positive - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then First_Exp - elsif Str (First_Exp + 1) in '-' | '+' then - Last_Number_Ghost (Str (First_Exp + 2 .. To)) + 1 - else Last_Number_Ghost (Str (First_Exp + 1 .. To)) + 1)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9', - Post => Raw_Unsigned_Last_Ghost'Result >= From; - -- Ghost function that returns the position of the cursor once an unsigned - -- number has been seen. - - function Slide_To_1 (Str : String) return String - with - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - (for all J in Str'First .. Str'Last => - Slide_To_1'Result (J - Str'First + 1) = ' '); - -- Slides Str so that it starts at 1 - - function Slide_If_Necessary (Str : String) return String is - (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); - -- If Str'Last = Positive'Last then slides Str so that it starts at 1 - - function Is_Unsigned_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last) - and then Only_Space_Ghost - (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number, consisting in some blank characters, an optional - -- + sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Unsigned_Ghost (Str : String; Val : Uns) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Val = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Unsigned_Ghost (Str); - -- Ghost function that returns True if Val is the value corresponding to - -- the unsigned number represented by Str. - - procedure Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Subprogram_Variant => (Increases => From), - Pre => Str1'Last /= Positive'Last - and then Str2'Last /= Positive'Last - and then - (From > To or else (From >= Str1'First and then To <= Str1'Last)) - and then - (From > To or else (From >= Str2'First and then To <= Str2'Last)) - and then Only_Hexa_Ghost (Str1, From, To) - and then (for all J in From .. To => Str1 (J) = Str2 (J)), - Post => - Scan_Based_Number_Ghost (Str1, From, To, Base, Acc) - = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc); - -- Scan_Based_Number_Ghost returns the same value on two slices which are - -- equal. - - procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - with - Pre => Str'Last /= Positive'Last - and then Str'Length >= 2 - and then Str (Str'First) = ' ' - and then Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) - and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last) - = Wrap_Option (Val), - Post => Is_Unsigned_Ghost (Slide_If_Necessary (Str)) - and then - Is_Value_Unsigned_Ghost (Slide_If_Necessary (Str), Val); - -- Ghost lemma used in the proof of 'Image implementation, to prove that - -- the result of Value_Unsigned on a decimal string is the same as the - -- result of Scan_Based_Number_Ghost. - - -- Bundle Uns type with other types, constants and subprograms used in - -- ghost code, so that this package can be instantiated once and used - -- multiple times as generic formal for a given Int type. - -private - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - -end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-veboop.adb b/gcc/ada/libgnat/s-veboop.adb index fb92f1c..edff485 100644 --- a/gcc/ada/libgnat/s-veboop.adb +++ b/gcc/ada/libgnat/s-veboop.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Vectors.Boolean_Operations with SPARK_Mode is @@ -86,26 +78,7 @@ is ----------- function "not" (Item : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Not (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Item) - and then Result = (Item xor True_Val), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = not Model (Item) (J)); - - procedure Prove_Not (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = 1 - Element (Item, J)); - end loop; - end Prove_Not; - begin - Prove_Not (Item xor True_Val); return Item xor True_Val; end "not"; @@ -119,32 +92,7 @@ is end Nand; function Nand (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_And (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left and Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) and Model (Right) (J))); - - procedure Prove_And (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - and Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_And; - begin - Prove_And (Left and Right); return not (Left and Right); end Nand; @@ -158,32 +106,7 @@ is end Nor; function Nor (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Or (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left or Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) or Model (Right) (J))); - - procedure Prove_Or (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - or Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_Or; - begin - Prove_Or (Left or Right); return not (Left or Right); end Nor; @@ -197,32 +120,7 @@ is end Nxor; function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Xor (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left xor Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) xor Model (Right) (J))); - - procedure Prove_Xor (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - xor Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_Xor; - begin - Prove_Xor (Left xor Right); return not (Left xor Right); end Nxor; diff --git a/gcc/ada/libgnat/s-veboop.ads b/gcc/ada/libgnat/s-veboop.ads index 6283d19..0b4f894 100644 --- a/gcc/ada/libgnat/s-veboop.ads +++ b/gcc/ada/libgnat/s-veboop.ads @@ -31,116 +31,21 @@ -- This package contains functions for runtime operations on boolean vectors --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - package System.Vectors.Boolean_Operations with Pure, SPARK_Mode is - pragma Warnings (Off, "aspect ""Pre"" not enforced on inlined subprogram", - Reason => "Pre only used in proof"); - pragma Warnings (Off, "aspect ""Post"" not enforced on inlined subprogram", - Reason => "Post only used in proof"); - -- Type Vectors.Vector represents an array of Boolean, each of which - -- takes 8 bits of the representation, with the 7 msb set to zero. Express - -- in contracts the constraint on valid vectors and the model that they - -- represent, and the relationship between input models and output model. - - Vector_Boolean_Size : constant Positive := - System.Word_Size / System.Storage_Unit - with Ghost; - - type Vector_Element is mod 2 ** System.Storage_Unit with Ghost; - - type Vector_Boolean_Array is array (1 .. Vector_Boolean_Size) of Boolean - with Ghost; - - function Shift_Right (V : Vectors.Vector; N : Natural) return Vectors.Vector - with Ghost, Import, Convention => Intrinsic; - - function Element (V : Vectors.Vector; N : Positive) return Vector_Element is - (Vector_Element (Shift_Right (V, (N - 1) * System.Storage_Unit) - and (2 ** System.Storage_Unit - 1))) - with - Ghost, - Pre => N <= Vector_Boolean_Size; - -- Return the Nth element represented by the vector - - function Valid (V : Vectors.Vector) return Boolean is - (for all J in 1 .. Vector_Boolean_Size => - Element (V, J) in 0 .. 1) - with Ghost; - -- A valid vector is one for which all elements are 0 (representing False) - -- or 1 (representing True). - - function Model (V : Vectors.Vector) return Vector_Boolean_Array - with - Ghost, - Pre => Valid (V); - - function Model (V : Vectors.Vector) return Vector_Boolean_Array is - (for J in 1 .. Vector_Boolean_Size => Element (V, J) = 1); - -- The model of a valid vector is the corresponding array of Boolean values - - -- Although in general the boolean operations on arrays of booleans are - -- identical to operations on arrays of unsigned words of the same size, - -- for the "not" operator this is not the case as False is typically - -- represented by 0 and true by 1. - - function "not" (Item : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Item), - Post => Valid ("not"'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model ("not"'Result) (J) = not Model (Item) (J)); - - function Nand (Left, Right : Boolean) return Boolean - with - Post => Nand'Result = not (Left and Right); - - function Nor (Left, Right : Boolean) return Boolean - with - Post => Nor'Result = not (Left or Right); - - function Nxor (Left, Right : Boolean) return Boolean - with - Post => Nxor'Result = not (Left xor Right); + -- takes 8 bits of the representation, with the 7 msb set to zero. - function Nand (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nand'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nand'Result) (J) = - Nand (Model (Left) (J), Model (Right) (J))); + function "not" (Item : Vectors.Vector) return Vectors.Vector; - function Nor (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nor'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nor'Result) (J) = - Nor (Model (Left) (J), Model (Right) (J))); + function Nand (Left, Right : Boolean) return Boolean; + function Nor (Left, Right : Boolean) return Boolean; + function Nxor (Left, Right : Boolean) return Boolean; - function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nxor'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nxor'Result) (J) = - Nxor (Model (Left) (J), Model (Right) (J))); + function Nand (Left, Right : Vectors.Vector) return Vectors.Vector; + function Nor (Left, Right : Vectors.Vector) return Vectors.Vector; + function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector; -- The three boolean operations "nand", "nor" and "nxor" are needed -- for cases where the compiler moves boolean array operations into -- the body of the loop that iterates over the array elements. diff --git a/gcc/ada/libgnat/s-vs_int.ads b/gcc/ada/libgnat/s-vs_int.ads deleted file mode 100644 index a4cc0dc..0000000 --- a/gcc/ada/libgnat/s-vs_int.ads +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ I N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning signed Integer --- values for use in ``Text_IO.Integer_IO``, and the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_Uns; - -package System.Vs_Int with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Unsigned is Unsigned_Types.Unsigned; - - package Spec is new System.Value_I_Spec - (Integer, Unsigned, System.Vs_Uns.Spec); - -end System.Vs_Int; diff --git a/gcc/ada/libgnat/s-vs_lli.ads b/gcc/ada/libgnat/s-vs_lli.ads deleted file mode 100644 index 3a4a010..0000000 --- a/gcc/ada/libgnat/s-vs_lli.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Integer values for use in ``Text_IO.Integer_IO``, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_LLU; - -package System.Vs_LLI with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Spec is new System.Value_I_Spec - (Long_Long_Integer, Long_Long_Unsigned, System.Vs_LLU.Spec); - -end System.Vs_LLI; diff --git a/gcc/ada/libgnat/s-vs_llu.ads b/gcc/ada/libgnat/s-vs_llu.ads deleted file mode 100644 index e1c0fec..0000000 --- a/gcc/ada/libgnat/s-vs_llu.ads +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Unsigned values for use in ``Text_IO.Modular_IO``, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_LLU with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Spec is new System.Value_U_Spec (Long_Long_Unsigned); - -end System.Vs_LLU; diff --git a/gcc/ada/libgnat/s-vs_uns.ads b/gcc/ada/libgnat/s-vs_uns.ads deleted file mode 100644 index 7e5aac3..0000000 --- a/gcc/ada/libgnat/s-vs_uns.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ U N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning modular Unsigned --- values for use in ``Text_IO.Modular_IO``, and the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_Uns with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Unsigned is Unsigned_Types.Unsigned; - - package Spec is new System.Value_U_Spec (Unsigned); - -end System.Vs_Uns; diff --git a/gcc/ada/libgnat/s-vsllli.ads b/gcc/ada/libgnat/s-vsllli.ads deleted file mode 100644 index 5648060..0000000 --- a/gcc/ada/libgnat/s-vsllli.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- ``Long_Long_Long_Integer`` values for use in ``Text_IO.Integer_IO``, and --- the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_LLLU; - -package System.Vs_LLLI with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Spec is new System.Value_I_Spec - (Long_Long_Long_Integer, Long_Long_Long_Unsigned, System.Vs_LLLU.Spec); - -end System.Vs_LLLI; diff --git a/gcc/ada/libgnat/s-vslllu.ads b/gcc/ada/libgnat/s-vslllu.ads deleted file mode 100644 index 7fe1235..0000000 --- a/gcc/ada/libgnat/s-vslllu.ads +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Long_Unsigned values for use in Text_IO.Modular_IO, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_LLLU with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Spec is new System.Value_U_Spec (Long_Long_Long_Unsigned); - -end System.Vs_LLLU; diff --git a/gcc/ada/libgnat/s-widint.ads b/gcc/ada/libgnat/s-widint.ads index 22e342c..8af8d91 100644 --- a/gcc/ada/libgnat/s-widint.ads +++ b/gcc/ada/libgnat/s-widint.ads @@ -31,24 +31,11 @@ -- Width attribute for signed integers up to Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_Int with SPARK_Mode is - function Width_Integer is new Width_I (Integer); pragma Pure_Function (Width_Integer); - end System.Wid_Int; diff --git a/gcc/ada/libgnat/s-widlli.ads b/gcc/ada/libgnat/s-widlli.ads index 3490b3f..a977096 100644 --- a/gcc/ada/libgnat/s-widlli.ads +++ b/gcc/ada/libgnat/s-widlli.ads @@ -31,24 +31,11 @@ -- Width attribute for signed integers larger than Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_LLI with SPARK_Mode is - function Width_Long_Long_Integer is new Width_I (Long_Long_Integer); pragma Pure_Function (Width_Long_Long_Integer); - end System.Wid_LLI; diff --git a/gcc/ada/libgnat/s-widllli.ads b/gcc/ada/libgnat/s-widllli.ads index ee8f7af..325e80f 100644 --- a/gcc/ada/libgnat/s-widllli.ads +++ b/gcc/ada/libgnat/s-widllli.ads @@ -31,25 +31,12 @@ -- Width attribute for signed integers larger than Long_Long_Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_LLLI with SPARK_Mode is - function Width_Long_Long_Long_Integer is new Width_I (Long_Long_Long_Integer); pragma Pure_Function (Width_Long_Long_Long_Integer); - end System.Wid_LLLI; diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads index db5b9d1..8a5c04f 100644 --- a/gcc/ada/libgnat/s-widlllu.ads +++ b/gcc/ada/libgnat/s-widlllu.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers larger than Long_Long_Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads index 0fd3135..f8c8284 100644 --- a/gcc/ada/libgnat/s-widllu.ads +++ b/gcc/ada/libgnat/s-widllu.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers larger than Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; diff --git a/gcc/ada/libgnat/s-widthi.adb b/gcc/ada/libgnat/s-widthi.adb index 9595790..c66d662 100644 --- a/gcc/ada/libgnat/s-widthi.adb +++ b/gcc/ada/libgnat/s-widthi.adb @@ -29,109 +29,9 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - function System.Width_I (Lo, Hi : Int) return Natural is - - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - package Signed_Conversion is new Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer renames - Signed_Conversion.To_Big_Integer; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Int'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) - with - Ghost, - Pre => A <= B, - Post => A * C <= B * C; - - procedure Lemma_Div_Commutation (X, Y : Int) - with - Ghost, - Pre => X >= 0 and Y > 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - ---------------------- - -- Lemma_Lower_Mult -- - ---------------------- - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is null; - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Div_Commutation (X, Y : Int) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - - -- Local variables - W : Natural; T : Int; - - -- Local ghost variables - - Max_W : constant Natural := Max_Log10 with Ghost; - Big_10 : constant Big_Integer := Big (10) with Ghost; - - Pow : Big_Integer := 1 with Ghost; - T_Init : constant Int := - Int'Max (abs Int'Max (Lo, Int'First + 1), - abs Int'Max (Hi, Int'First + 1)) - with Ghost; - --- Start of processing for System.Width_I - begin if Lo > Hi then return 0; @@ -151,41 +51,10 @@ begin -- Increase value if more digits required while T >= 10 loop - Lemma_Div_Commutation (T, 10); - Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10); - T := T / 10; W := W + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (T >= 0); - pragma Loop_Invariant (W in 3 .. Max_W + 3); - pragma Loop_Invariant (Pow = Big_10 ** (W - 2)); - pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow); - pragma Loop_Variant (Decreases => T); end loop; - declare - F : constant Big_Positive := Big_10 ** (W - 2) with Ghost; - Q : constant Big_Natural := Big (T_Init) / F with Ghost; - R : constant Big_Natural := Big (T_Init) rem F with Ghost; - begin - pragma Assert (Q < Big_10); - pragma Assert (Big (T_Init) = Q * F + R); - Lemma_Lower_Mult (Q, Big (9), F); - pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); - pragma Assert (Big (T_Init) < Big_10 * F); - pragma Assert (Big_10 * F = Big_10 ** (W - 1)); - end; - - -- This is an expression of the functional postcondition for Width_I, - -- which cannot be expressed readily as a postcondition as this would - -- require making the instantiation Signed_Conversion and function Big - -- available from the spec. - - pragma Assert (Big (Int'Max (Lo, Int'First + 1)) < Big_10 ** (W - 1)); - pragma Assert (Big (Int'Max (Hi, Int'First + 1)) < Big_10 ** (W - 1)); - return W; end if; diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb index df27e50..fe51d61 100644 --- a/gcc/ada/libgnat/s-widthu.adb +++ b/gcc/ada/libgnat/s-widthu.adb @@ -31,110 +31,12 @@ package body System.Width_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - function Width (Lo, Hi : Uns) return Natural is - - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) - with - Ghost, - Pre => A <= B, - Post => A * C <= B * C; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) - with - Ghost, - Pre => F > 0 and then Q = V / F and then R = V rem F, - Post => V = Q * F + R; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by F and the value V. - - ---------------------- - -- Lemma_Lower_Mult -- - ---------------------- - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is null; - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - - --------------------- - -- Lemma_Euclidian -- - --------------------- - - procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) is null; - - -- Local variables - W : Natural; T : Uns; - - -- Local ghost variables - - Max_W : constant Natural := Max_Log10 with Ghost; - Pow : Big_Integer := 1 with Ghost; - T_Init : constant Uns := Uns'Max (Lo, Hi) with Ghost; - - -- Start of processing for System.Width_U - begin if Lo > Hi then return 0; - else -- Minimum value is 2, one for space, one for digit @@ -147,32 +49,10 @@ package body System.Width_U is -- Increase value if more digits required while T >= 10 loop - Lemma_Div_Commutation (T, 10); - Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10); - T := T / 10; W := W + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (W in 3 .. Max_W + 2); - pragma Loop_Invariant (Pow = Big_10 ** (W - 2)); - pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow); - pragma Loop_Variant (Decreases => T); end loop; - declare - F : constant Big_Integer := Big_10 ** (W - 2) with Ghost; - Q : constant Big_Integer := Big (T_Init) / F with Ghost; - R : constant Big_Integer := Big (T_Init) rem F with Ghost; - begin - pragma Assert (Q < Big_10); - Lemma_Euclidian (Big (T_Init), Q, F, R); - Lemma_Lower_Mult (Q, Big (9), F); - pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); - pragma Assert (Big (T_Init) < Big_10 * F); - pragma Assert (Big_10 * F = Big_10 ** (W - 1)); - end; - return W; end if; end Width; diff --git a/gcc/ada/libgnat/s-widthu.ads b/gcc/ada/libgnat/s-widthu.ads index 56da0a2..076dace 100644 --- a/gcc/ada/libgnat/s-widthu.ads +++ b/gcc/ada/libgnat/s-widthu.ads @@ -29,65 +29,14 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -- Compute Width attribute for non-static type derived from a modular integer -- type. The arguments Lo, Hi are the bounds of the type. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Uns is mod <>; package System.Width_U with Pure is - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - subtype Big_Natural is BI_Ghost.Big_Natural with Ghost; - subtype Big_Positive is BI_Ghost.Big_Positive with Ghost; - use type BI_Ghost.Big_Integer; - - package Unsigned_Conversion is - new BI_Ghost.Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - Big_10 : constant Big_Integer := Big (Uns'(10)) with Ghost; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Uns'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - function Width (Lo, Hi : Uns) return Natural - with - Post => - (declare - W : constant Natural := System.Width_U.Width'Result; - begin - (if Lo > Hi then W = 0 - else W > 0 - and then W <= Max_Log10 + 2 - and then Big (Lo) < Big_10 ** (W - 1) - and then Big (Hi) < Big_10 ** (W - 1))); - + function Width (Lo, Hi : Uns) return Natural; end System.Width_U; diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads index d81b862..6ac2928 100644 --- a/gcc/ada/libgnat/s-widuns.ads +++ b/gcc/ada/libgnat/s-widuns.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers up to Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index daa87d9..7182fb8 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -609,6 +609,7 @@ private -- Int Value associated with this name end record; + -- The aliased non-boolean components are required to match the C structure for Name_Entry use record Name_Chars_Index at 0 range 0 .. 31; @@ -622,9 +623,10 @@ private Hash_Link at 8 range 0 .. 31; Int_Info at 12 range 0 .. 31; end record; + -- This ensures a matching layout between Ada and C for Name_Entry'Size use 16 * 8; - -- This ensures that we did not leave out any fields + -- This ensures that record is reasonably small -- This is the table that is referenced by Valid_Name_Id entries. -- It contains one entry for each unique name in the table. diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index e5228f5..a018199 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -125,19 +125,10 @@ package body Nlists is -------------------------- procedure Allocate_List_Tables (N : Node_Or_Entity_Id) is - Old_Last : constant Node_Or_Entity_Id'Base := Next_Node.Last; - begin - pragma Assert (N >= Old_Last); + pragma Assert (N >= Next_Node.Last); Next_Node.Set_Last (N); Prev_Node.Set_Last (N); - - -- Make sure we have no uninitialized junk in any new entries added. - - for J in Old_Last + 1 .. N loop - Next_Node.Table (J) := Empty; - Prev_Node.Table (J) := Empty; - end loop; end Allocate_List_Tables; ------------ diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 687d1ed..cbe4701 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -308,6 +308,10 @@ package Opt is -- GNATMAKE -- Set to True to check readonly files during the make process + Check_Semantics_Only_Mode : Boolean := False; + -- GNATMAKE + -- Set to True when -gnatc is present to only perform semantic checking. + Check_Source_Files : Boolean := True; -- GNATBIND, GNATMAKE -- Set to True to enable consistency checking for any source files that @@ -1518,10 +1522,6 @@ package Opt is -- used for inconsistency error messages. A value of System_Location is -- used if the policy is set in package System. - Tasking_Used : Boolean := False; - -- Set True if any tasking construct is encountered. Used to activate the - -- output of the Q, L and T lines in ALI files. - Time_Slice_Set : Boolean := False; -- GNATBIND -- Set True if a pragma Time_Slice is processed in the main unit, or diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index bf2affe..26b0dbb 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -64,6 +64,14 @@ package body Osint is -- Used in Locate_File as a fake directory when Name is already an -- absolute path. + procedure Get_Current_Dir + (Dir : System.Address; Length : System.Address); + pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); + + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- Maximum length of a path name + ------------------------------------- -- Use of Name_Find and Name_Enter -- ------------------------------------- @@ -1426,6 +1434,24 @@ package body Osint is Smart_Find_File (N, Source, Full_File, Attr.all); end Full_Source_Name; + --------------------- + -- Get_Current_Dir -- + --------------------- + + function Get_Current_Dir return String is + Path_Len : Natural := Max_Path; + Buffer : String (1 .. 1 + Max_Path + 1); + + begin + Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Path_Len = 0 then + raise Program_Error; + end if; + + return Buffer (1 .. Path_Len); + end Get_Current_Dir; + ------------------- -- Get_Directory -- ------------------- @@ -1517,15 +1543,6 @@ package body Osint is (Search_Dir : String; File_Type : Search_File_Type) return String_Ptr is - procedure Get_Current_Dir - (Dir : System.Address; - Length : System.Address); - pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); - - Max_Path : Integer; - pragma Import (C, Max_Path, "__gnat_max_path_len"); - -- Maximum length of a path name - Current_Dir : String_Ptr; Default_Search_Dir : String_Access; Default_Suffix_Dir : String_Access; @@ -2732,6 +2749,84 @@ package body Osint is end Read_Source_File; ------------------- + -- Relative_Path -- + ------------------- + + function Relative_Path (Path : String; Ref : String) return String is + Norm_Path : constant String := + Normalize_Pathname (Name => Path, Resolve_Links => False); + Norm_Ref : constant String := + Normalize_Pathname (Name => Ref, Resolve_Links => False); + Rel_Path : Bounded_String; + Last : Natural := Norm_Ref'Last; + Old : Natural; + Depth : Natural := 0; + + begin + pragma Assert (System.OS_Lib.Is_Absolute_Path (Norm_Path)); + pragma Assert (System.OS_Lib.Is_Absolute_Path (Norm_Ref)); + pragma Assert (System.OS_Lib.Is_Directory (Norm_Ref)); + + -- If the root drives are different on Windows then we cannot create a + -- relative path. + + if Root (Norm_Path) /= Root (Norm_Ref) then + return Norm_Path; + end if; + + if Norm_Path = Norm_Ref then + return "."; + end if; + + loop + exit when Last - Norm_Ref'First + 1 <= Norm_Path'Length + and then + Norm_Path + (Norm_Path'First .. + Norm_Path'First + Last - Norm_Ref'First) = + Norm_Ref (Norm_Ref'First .. Last); + + Old := Last; + for J in reverse Norm_Ref'First .. Last - 1 loop + if Is_Directory_Separator (Norm_Ref (J)) then + Depth := Depth + 1; + Last := J; + exit; + end if; + end loop; + + if Old = Last then + -- No Dir_Separator in Ref... Let's return Path + return Norm_Path; + end if; + end loop; + + -- Move up the directory chain to the common point + + for I in 1 .. Depth loop + Append (Rel_Path, ".." & System.OS_Lib.Directory_Separator); + end loop; + + -- Avoid starting the relative path with a directory separator + + if Last < Norm_Path'Length + and then Is_Directory_Separator (Norm_Path (Norm_Path'First + Last)) + then + Last := Last + 1; + end if; + + -- Add the rest of the path from the common point + + Append + (Rel_Path, + Norm_Path + (Norm_Path'First + Last - Norm_Ref'First + 1 .. + Norm_Path'Last)); + + return To_String (Rel_Path); + end Relative_Path; + + ------------------- -- Relocate_Path -- ------------------- @@ -2788,6 +2883,25 @@ package body Osint is return new String'(Path); end Relocate_Path; + ---------- + -- Root -- + ---------- + + function Root (Path : String) return String is + Last : Natural := Path'First; + begin + pragma Assert (System.OS_Lib.Is_Absolute_Path (Path)); + + for I in Path'Range loop + if Is_Directory_Separator (Path (I)) then + Last := I; + exit; + end if; + end loop; + + return Path (Path'First .. Last); + end Root; + ----------------- -- Set_Program -- ----------------- diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 041af41..77aaf04 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -166,6 +166,9 @@ package Osint is function Is_Directory_Separator (C : Character) return Boolean; -- Returns True if C is a directory separator + function Get_Current_Dir return String; + -- Returns the current working directory for the execution environment + function Get_Directory (Name : File_Name_Type) return File_Name_Type; -- Get the prefix directory name (if any) from Name. The last separator -- is preserved. Return the normalized current directory if there is no @@ -230,6 +233,15 @@ package Osint is (Canonical_File : String) return String_Access; -- Convert a canonical syntax file specification to host syntax + function Relative_Path (Path : String; Ref : String) return String; + -- Given an absolute path Path calculate its relative path from a reference + -- directory Ref. + -- + -- If the paths are the same it will return ".". + -- + -- If the paths are on different drives on Windows based systems then it + -- will return the normalized version of Path. + function Relocate_Path (Prefix : String; Path : String) return String_Ptr; @@ -243,6 +255,9 @@ package Osint is -- If the above computation fails, return Path. This function assumes -- Prefix'First = Path'First. + function Root (Path : String) return String; + -- Return the root of an absolute Path. + function Shared_Lib (Name : String) return String; -- Returns the runtime shared library in the form -l<name>-<version> where -- version is the GNAT runtime library option for the platform. For example diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index ca02f1b..8267a0c 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -592,6 +592,20 @@ package body Ch4 is Explicit_Actual_Parameter => Rnam)); exit; + -- 'Make is a special attribute that takes a variable + -- amount of parameters. + + elsif All_Extensions_Allowed + and then Attr_Name = Name_Make + then + Scan; + Rnam := P_Expression; + Append_To (Expressions (Name_Node), + Make_Parameter_Association (Sloc (Rnam), + Selector_Name => Expr, + Explicit_Actual_Parameter => Rnam)); + exit; + -- For all other cases named notation is illegal else @@ -3473,8 +3487,9 @@ package body Ch4 is function P_Allocator return Node_Id is Alloc_Node : Node_Id; - Type_Node : Node_Id; Null_Exclusion_Present : Boolean; + Scan_State : Saved_Scan_State; + Type_Node : Node_Id; begin Alloc_Node := New_Node (N_Allocator, Token_Ptr); @@ -3496,6 +3511,31 @@ package body Ch4 is Null_Exclusion_Present := P_Null_Exclusion; Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present); + + -- Check for 'Make + + if All_Extensions_Allowed + and then Token = Tok_Identifier + then + Save_Scan_State (Scan_State); + Type_Node := P_Qualified_Simple_Name_Resync; + if Token = Tok_Apostrophe then + Scan; + if Token_Name = Name_Make then + Restore_Scan_State (Scan_State); + Set_Expression + (Alloc_Node, + Make_Qualified_Expression (Token_Ptr, + Subtype_Mark => Check_Subtype_Mark (Type_Node), + Expression => P_Expression_Or_Range_Attribute)); + return Alloc_Node; + end if; + end if; + Restore_Scan_State (Scan_State); + end if; + + -- Otherwise continue parsing the subtype + Type_Node := P_Subtype_Mark_Resync; if Token = Tok_Apostrophe then diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index ac78b60..12baed4 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -23,12 +23,12 @@ -- -- ------------------------------------------------------------------------------ +with Errid; use Errid; with Namet.Sp; use Namet.Sp; with Stringt; use Stringt; with Uintp; use Uintp; with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; -with Diagnostics.Constructors; use Diagnostics.Constructors; separate (Par) package body Endh is @@ -899,6 +899,8 @@ package body Endh is Wrong_End_Start : Source_Ptr; Wrong_End_Finish : Source_Ptr; + + Wrong_End_Span : Source_Span; begin -- Suppress message if this was a potentially junk entry (e.g. a record -- entry where no record keyword was present). @@ -936,31 +938,38 @@ package body Endh is elsif End_Type = E_Loop then if Error_Msg_Node_1 = Empty then - if Debug_Flag_Underscore_DD then - - -- TODO: This is a quick hack to get the location of the - -- END LOOP for the demonstration. - - Wrong_End_Start := Token_Ptr; - - while Token /= Tok_Semicolon loop - Scan; -- past semicolon - end loop; - - Wrong_End_Finish := Token_Ptr; + Wrong_End_Start := Token_Ptr; - Restore_Scan_State (Scan_State); - - Record_End_Loop_Expected_Error - (End_Loc => To_Span (First => Wrong_End_Start, - Ptr => Wrong_End_Start, - Last => Wrong_End_Finish), - Start_Loc => Error_Msg_Sloc); + while Token /= Tok_Semicolon loop + Scan; -- past semicolon + end loop; - else - Error_Msg_SC -- CODEFIX - ("`END LOOP;` expected@ for LOOP#!"); - end if; + Wrong_End_Finish := Token_Ptr; + + Wrong_End_Span := + To_Span + (First => Wrong_End_Start, + Ptr => Wrong_End_Start, + Last => Wrong_End_Finish); + + Restore_Scan_State (Scan_State); + + Error_Msg -- CODEFIX + (Msg => "`END LOOP;` expected@ for LOOP#!", + Flag_Span => Wrong_End_Span, + N => Empty, + Error_Code => GNAT0004, + Spans => + (1 => Secondary_Labeled_Span (To_Span (Error_Msg_Sloc))), + Fixes => + (1 => + Fix + (Description => "Replace with 'end loop;'", + Edits => + (1 => + Edit + (Text => "end loop;", + Span => Wrong_End_Span))))); else Error_Msg_SC -- CODEFIX ("`END LOOP &;` expected@!"); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 6efb16d..4d0ffe6 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1548,6 +1548,7 @@ begin | Pragma_Priority_Specific_Dispatching | Pragma_Profile | Pragma_Profile_Warnings + | Pragma_Program_Exit | Pragma_Propagate_Exceptions | Pragma_Provide_Shift_Operators | Pragma_Psect_Object diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index cd4b664..a6dff7c 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -77,20 +77,6 @@ package body Repinfo is Op3 : Node_Ref_Or_Val; end record; - -- The following representation clause ensures that the above record - -- has no holes. We do this so that when instances of this record are - -- written, we do not write uninitialized values to the file. - - for Exp_Node use record - Expr at 0 range 0 .. 31; - Op1 at 4 range 0 .. 31; - Op2 at 8 range 0 .. 31; - Op3 at 12 range 0 .. 31; - end record; - - for Exp_Node'Size use 16 * 8; - -- This ensures that we did not leave out any fields - package Rep_Table is new Table.Table ( Table_Component_Type => Exp_Node, Table_Index_Type => Nat, diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 70a6f12..86713ff 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -566,11 +566,11 @@ package body Rtsfind is subtype Ada_Numerics_Descendant is Ada_Descendant range Ada_Numerics_Big_Numbers .. - Ada_Numerics_Big_Numbers_Big_Integers_Ghost; + Ada_Numerics_Big_Numbers_Big_Integers; subtype Ada_Numerics_Big_Numbers_Descendant is Ada_Descendant range Ada_Numerics_Big_Numbers_Big_Integers .. - Ada_Numerics_Big_Numbers_Big_Integers_Ghost; + Ada_Numerics_Big_Numbers_Big_Integers; subtype Ada_Real_Time_Descendant is Ada_Descendant range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index d57d4fa..37ed22b1 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -121,7 +121,6 @@ package Rtsfind is -- Children of Ada.Numerics.Big_Numbers Ada_Numerics_Big_Numbers_Big_Integers, - Ada_Numerics_Big_Numbers_Big_Integers_Ghost, -- Children of Ada.Real_Time @@ -582,7 +581,6 @@ package Rtsfind is RE_Reference, -- Ada.Interrupts RE_Big_Integer, -- Ada.Numerics.Big_Numbers.Big_Integers - RO_GH_Big_Integer, -- Ada.Numerics.Big_Numbers.Big_Integers_Ghost RO_SP_Big_Integer, -- SPARK.Big_Integers RE_Names, -- Ada.Interrupts.Names @@ -2231,7 +2229,6 @@ package Rtsfind is RE_Reference => Ada_Interrupts, RE_Big_Integer => Ada_Numerics_Big_Numbers_Big_Integers, - RO_GH_Big_Integer => Ada_Numerics_Big_Numbers_Big_Integers_Ghost, RO_SP_Big_Integer => SPARK_Big_Integers, RE_Names => Ada_Interrupts_Names, diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index a2ade8a..b5f39c9 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -28,9 +28,6 @@ -- the ALI file, and by Get_SCO/Put_SCO to read and write the text form that -- is used in the ALI file. --- WARNING: There is a C version of this package. Any changes to this --- source file must be properly reflected in the C header file scos.h - with Namet; use Namet; with Table; with Types; use Types; diff --git a/gcc/ada/scos.h b/gcc/ada/scos.h deleted file mode 100644 index 3d800bf..0000000 --- a/gcc/ada/scos.h +++ /dev/null @@ -1,89 +0,0 @@ -/**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * S C O S * - * * - * C Header File * - * * - * Copyright (C) 2014-2025, 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. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING3. If not, go to * - * http://www.gnu.org/licenses for a complete copy of the license. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - -/* This is the C header that corresponds to the Ada package specification for - Scos. It was created manually from scos.ads and must be kept synchronized - with changes in this file. */ - -#ifdef __cplusplus -extern "C" { -#endif - - -/* Unit table: */ - -typedef Int SCO_Unit_Index; - -struct SCO_Unit_Table_Entry - { - String_Pointer File_Name; - Int File_Index; - Nat Dep_Num; - Nat From, To; - }; - -typedef struct SCO_Unit_Table_Entry *SCO_Unit_Table_Type; - -extern SCO_Unit_Table_Type scos__sco_unit_table__table; -#define SCO_Unit_Table scos__sco_unit_table__table - -extern Int scos__sco_unit_table__min; -#define SCO_Unit_Table_Min scos__sco_unit_table__min - -extern Int scos__sco_unit_table__last_val; -#define SCO_Unit_Table_Last_Val scos__sco_unit_table__last_val - - -/* SCOs table: */ - -struct Source_Location - { - Line_Number_Type Line; - Column_Number_Type Col; - }; - -struct SCO_Table_Entry - { - struct Source_Location From, To; - char C1, C2; - bool Last; - Source_Ptr Pragma_Sloc; - Name_Id Pragma_Aspect_Name; - }; - -typedef struct SCO_Table_Entry *SCO_Table_Type; - -extern SCO_Table_Type scos__sco_table__table; -#define SCO_Table scos__sco_table__table - -extern Int scos__sco_table__min; -#define SCO_Table_Min scos__sco_table__min - -extern Int scos__sco_table__last_val; -#define SCO_Table_Last_Val scos__sco_table__last_val - -#ifdef __cplusplus -} -#endif diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index f8a67a9..6113097 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -109,7 +109,7 @@ -- pragmas that appear with subprogram specifications rather than in the body. -- Collectively we call these Spec_Expressions. The routine that performs the --- special analysis is called Preanalyze_Spec_Expression. +-- special analysis is called Preanalyze_And_Resolve_Spec_Expression. -- Expansion has to be deferred since you can't generate code for expressions -- that reference types that have not been frozen yet. As an example, consider @@ -198,11 +198,11 @@ -- strict preanalysis of other expressions is that we do carry out freezing -- in the former (for static scalar expressions) but not in the latter. The -- routine that performs preanalysis of default expressions is called --- Preanalyze_Spec_Expression and is in Sem_Ch3. The routine that performs --- strict preanalysis and corresponding resolution is in Sem_Res and it is --- called Preanalyze_And_Resolve. Preanalyze_Spec_Expression relaxes the --- strictness of Preanalyze_And_Resolve setting to True the global boolean --- variable In_Spec_Expression before calling Preanalyze_And_Resolve. +-- Preanalyze_And_Resolve_Spec_Expression and is in Sem_Ch3. The routine that +-- performs strict preanalysis and corresponding resolution is in Sem_Res and +-- it is called Preanalyze_And_Resolve. Preanalyze_And_Resolve_Spec_Expression +-- relaxes the strictness of Preanalyze_And_Resolve setting to True the global +-- boolean variable In_Spec_Expression before calling Preanalyze_And_Resolve. with Alloc; with Einfo.Entities; use Einfo.Entities; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index a7ec772..f4fa1ad 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -26,11 +26,10 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; -with Debug; use Debug; -with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; +with Errid; use Errid; with Errout; use Errout; with Expander; use Expander; with Exp_Tss; use Exp_Tss; @@ -4038,15 +4037,18 @@ package body Sem_Aggr is if Present (First (Expressions (N))) and then Present (First (Component_Associations (N))) then - if Debug_Flag_Underscore_DD then - Record_Mixed_Container_Aggregate_Error - (Aggr => N, - Pos_Elem => First (Expressions (N)), - Named_Elem => First (Component_Associations (N))); - else - Error_Msg_N - ("container aggregate cannot be both positional and named", N); - end if; + Error_Msg_N + (Msg => + "container aggregate cannot be both positional and named", + N => N, + Error_Code => GNAT0006, + Spans => + (1 => + Secondary_Labeled_Span + (First (Expressions (N)), "positional element "), + 2 => + Secondary_Labeled_Span + (First (Component_Associations (N)), "named element"))); return; end if; @@ -6984,6 +6986,30 @@ package body Sem_Aggr is -- Check the dimensions of the components in the record aggregate Analyze_Dimension_Extension_Or_Record_Aggregate (N); + + -- Do a pass for constructors which rely on things being fully expanded + + declare + function Resolve_Make_Expr (N : Node_Id) return Traverse_Result; + -- Recurse in the aggregate and resolve references to 'Make + + function Resolve_Make_Expr (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Make + then + Set_Analyzed (N, False); + Resolve (N); + end if; + + return OK; + end Resolve_Make_Expr; + + procedure Search_And_Resolve_Make_Expr is new + Traverse_Proc (Resolve_Make_Expr); + begin + Search_And_Resolve_Make_Expr (N); + end; end Resolve_Record_Aggregate; ----------------------------- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index af08fdb..bf4d684 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1462,6 +1462,13 @@ package body Sem_Attr is then null; + -- Attribute 'Old is allowed to appear in Program_Exit + + elsif Prag_Nam = Name_Program_Exit + and then Aname = Name_Old + then + null; + elsif Prag_Nam = Name_Test_Case then Check_Placement_In_Test_Case (Prag); @@ -3317,7 +3324,7 @@ package body Sem_Attr is E1 := Empty; E2 := Empty; - else + elsif Aname /= Name_Make then E1 := First (Exprs); -- Skip analysis for case of Restriction_Set, we do not expect @@ -5164,6 +5171,36 @@ package body Sem_Attr is Check_Not_Incomplete_Type; Set_Etype (N, Universal_Integer); + ---------- + -- Make -- + ---------- + + when Attribute_Make => declare + Expr : Entity_Id; + begin + -- Should this be assert? Parsing should fail if it hits 'Make + -- and all extensions aren't enabled ??? + + if not All_Extensions_Allowed then + return; + end if; + + Set_Etype (N, Etype (P)); + + if Present (Expressions (N)) then + Expr := First (Expressions (N)); + while Present (Expr) loop + if Nkind (Expr) = N_Parameter_Association then + Analyze (Explicit_Actual_Parameter (Expr)); + else + Analyze (Expr); + end if; + + Next (Expr); + end loop; + end if; + end; + -------------- -- Mantissa -- -------------- @@ -7511,13 +7548,14 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); Validate_Non_Static_Attribute_Function_Call; - if P_Type in Standard_Boolean + if Root_Type (P_Type) in Standard_Boolean | Standard_Character | Standard_Wide_Character | Standard_Wide_Wide_Character then Error_Attr_P - ("prefix of % attribute must not be a type in Standard"); + ("prefix of % attribute must not be a type originating from " & + "Standard"); end if; if Discard_Names (First_Subtype (P_Type)) then @@ -8712,6 +8750,13 @@ package body Sem_Attr is Set_Etype (N, C_Type); return; + -- Handle 'Make constructor calls + + elsif All_Extensions_Allowed + and then Id = Attribute_Make + then + P_Type := P_Entity; + -- No other cases are foldable (they certainly aren't static, and at -- the moment we don't try to fold any cases other than the ones above). @@ -8723,9 +8768,10 @@ package body Sem_Attr is -- If either attribute or the prefix is Any_Type, then propagate -- Any_Type to the result and don't do anything else at all. - if P_Type = Any_Type + if Id /= Attribute_Make + and then (P_Type = Any_Type or else (Present (E1) and then Etype (E1) = Any_Type) - or else (Present (E2) and then Etype (E2) = Any_Type) + or else (Present (E2) and then Etype (E2) = Any_Type)) then Set_Etype (N, Any_Type); return; @@ -8838,7 +8884,9 @@ package body Sem_Attr is Static := False; Set_Is_Static_Expression (N, False); - elsif Id /= Attribute_Max_Alignment_For_Allocation then + elsif Id not in Attribute_Max_Alignment_For_Allocation + | Attribute_Make + then if not Is_Constrained (P_Type) or else (Id /= Attribute_First and then Id /= Attribute_Last and then @@ -8914,53 +8962,55 @@ package body Sem_Attr is -- of the expressions to be scalar in order for the attribute to be -- considered to be static. - declare - E : Node_Id; + if Id /= Attribute_Make then + declare + E : Node_Id; - begin - E := E1; + begin + E := E1; - while Present (E) loop + while Present (E) loop - -- If expression is not static, then the attribute reference - -- result certainly cannot be static. + -- If expression is not static, then the attribute reference + -- result certainly cannot be static. - if not Is_Static_Expression (E) then - Static := False; - Set_Is_Static_Expression (N, False); - end if; + if not Is_Static_Expression (E) then + Static := False; + Set_Is_Static_Expression (N, False); + end if; - if Raises_Constraint_Error (E) then - Set_Raises_Constraint_Error (N); - end if; + if Raises_Constraint_Error (E) then + Set_Raises_Constraint_Error (N); + end if; - -- If the result is not known at compile time, or is not of - -- a scalar type, then the result is definitely not static, - -- so we can quit now. + -- If the result is not known at compile time, or is not of + -- a scalar type, then the result is definitely not static, + -- so we can quit now. - if not Compile_Time_Known_Value (E) - or else not Is_Scalar_Type (Etype (E)) - then - Check_Expressions; - return; + if not Compile_Time_Known_Value (E) + or else not Is_Scalar_Type (Etype (E)) + then + Check_Expressions; + return; - -- If the expression raises a constraint error, then so does - -- the attribute reference. We keep going in this case because - -- we are still interested in whether the attribute reference - -- is static even if it is not static. + -- If the expression raises a constraint error, then so does + -- the attribute reference. We keep going in this case because + -- we are still interested in whether the attribute reference + -- is static even if it is not static. - elsif Raises_Constraint_Error (E) then - Set_Raises_Constraint_Error (N); - end if; + elsif Raises_Constraint_Error (E) then + Set_Raises_Constraint_Error (N); + end if; - Next (E); - end loop; + Next (E); + end loop; - if Raises_Constraint_Error (Prefix (N)) then - Set_Is_Static_Expression (N, False); - return; - end if; - end; + if Raises_Constraint_Error (Prefix (N)) then + Set_Is_Static_Expression (N, False); + return; + end if; + end; + end if; -- Deal with the case of a static attribute reference that raises -- constraint error. The Raises_Constraint_Error flag will already @@ -9778,6 +9828,13 @@ package body Sem_Attr is end if; end Machine_Size; + ---------- + -- Make -- + ---------- + + when Attribute_Make => + Set_Etype (N, Etype (Prefix (N))); + -------------- -- Mantissa -- -------------- @@ -11095,7 +11152,9 @@ package body Sem_Attr is -- If this is still an attribute reference, then it has not been folded -- and that means that its expressions are in a non-static context. - elsif Nkind (N) = N_Attribute_Reference then + elsif Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) /= Name_Make + then Check_Expressions; -- Note: the else case not covered here are odd cases where the @@ -12960,6 +13019,7 @@ package body Sem_Attr is if Expander_Active and then Present (Expressions (N)) + and then Attr_Id /= Attribute_Make then declare Expr : Node_Id := First (Expressions (N)); diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 8208048..1c54370 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -319,6 +319,12 @@ package Sem_Attr is -- This attribute is identical to the Object_Size attribute. It is -- provided for compatibility with the DEC attribute of this name. + ---------- + -- Make -- + ---------- + + Attribute_Make => True, + ---------------------- -- Max_Integer_Size -- ---------------------- diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index de5a8c8..25bba9b 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -123,15 +123,6 @@ package body Sem_Ch10 is -- Verify that a stub is declared immediately within a compilation unit, -- and not in an inner frame. - procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id); - -- When a child unit appears in a context clause, the implicit withs on - -- parents are made explicit, and with clauses are inserted in the context - -- clause before the one for the child. If a parent in the with_clause - -- is a renaming, the implicit with_clause is on the renaming whose name - -- is mentioned in the with_clause, and not on the package it renames. - -- N is the compilation unit whose list of context items receives the - -- implicit with_clauses. - procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id); -- Generate cross-reference information for the parents of child units -- and of subunits. N is a defining_program_unit_name, and P_Id is the @@ -2955,6 +2946,7 @@ package body Sem_Ch10 is if Ada_Version >= Ada_95 and then In_Predefined_Renaming (U) + and then Comes_From_Source (N) then if Restriction_Check_Required (No_Obsolescent_Features) then Check_Restriction (No_Obsolescent_Features, N); @@ -4932,6 +4924,8 @@ package body Sem_Ch10 is if Entity (Name (Clause)) = Id or else (Nkind (Name (Clause)) = N_Expanded_Name + and then + Is_Entity_Name (Prefix (Name (Clause))) and then Entity (Prefix (Name (Clause))) = Id) then return True; diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads index c80c412..9585785 100644 --- a/gcc/ada/sem_ch10.ads +++ b/gcc/ada/sem_ch10.ads @@ -45,6 +45,15 @@ package Sem_Ch10 is -- set when Ent is a tagged type and its class-wide type needs to appear -- in the tree. + procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id); + -- When a child unit appears in a context clause, the implicit withs on + -- parents are made explicit, and with clauses are inserted in the context + -- clause before the one for the child. If a parent in the with_clause + -- is a renaming, the implicit with_clause is on the renaming whose name + -- is mentioned in the with_clause, and not on the package it renames. + -- N is the compilation unit whose list of context items receives the + -- implicit with_clauses. + procedure Install_Context (N : Node_Id; Chain : Boolean := True); -- Installs the entities from the context clause of the given compilation -- unit into the visibility chains. This is done before analyzing a unit. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5768e28e..3a31a92 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -276,6 +276,7 @@ package body Sem_Ch12 is -- Pre -- Pre_Class -- Precondition + -- Program_Exit -- Refined_Depends -- Refined_Global -- Refined_Post @@ -3371,7 +3372,7 @@ package body Sem_Ch12 is end if; if Present (E) then - Preanalyze_Spec_Expression (E, T); + Preanalyze_And_Resolve_Spec_Expression (E, T); -- The default for a ghost generic formal IN parameter of -- access-to-variable type should be a ghost object (SPARK @@ -4195,7 +4196,7 @@ package body Sem_Ch12 is elsif Present (Expr) then Push_Scope (Nam); Install_Formals (Nam); - Preanalyze_Spec_Expression (Expr, Etype (Nam)); + Preanalyze_And_Resolve_Spec_Expression (Expr, Etype (Nam)); End_Scope; end if; @@ -13034,10 +13035,6 @@ package body Sem_Ch12 is Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); Preserve_Comes_From_Source (Act_Body_Id, Act_Decl_Id); - -- Some attributes of spec entity are not inherited by body entity - - Set_Handler_Records (Act_Body_Id, No_List); - if Nkind (Defining_Unit_Name (Act_Spec)) = N_Defining_Program_Unit_Name then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 072ec66..76a8c0b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -29,11 +29,11 @@ with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; with Debug; use Debug; -with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; +with Errid; use Errid; with Errout; use Errout; with Exp_Ch3; use Exp_Ch3; with Exp_Disp; use Exp_Disp; @@ -54,6 +54,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aggr; use Sem_Aggr; with Sem_Aux; use Sem_Aux; with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; @@ -1620,6 +1621,7 @@ package body Sem_Ch13 is -- Part_Of -- Post -- Pre + -- Program_Exit -- Refined_Depends -- Refined_Global -- Refined_Post @@ -1872,11 +1874,11 @@ package body Sem_Ch13 is -- analyzed right now. -- Note that there is a special handling for Pre, Post, Test_Case, - -- Contract_Cases, Always_Terminates, Exit_Cases, Exceptional_Cases and - -- Subprogram_Variant aspects. In these cases, we do not have to worry - -- about delay issues, since the pragmas themselves deal with delay of - -- visibility for the expression analysis. Thus, we just insert the - -- pragma after the node N. + -- Contract_Cases, Always_Terminates, Exit_Cases, Exceptional_Cases, + -- Program_Exit and Subprogram_Variant aspects. In these cases, we do + -- not have to worry about delay issues, since the pragmas themselves + -- deal with delay of visibility for the expression analysis. Thus, we + -- just insert the pragma after the node N. if No (L) then return; @@ -3873,6 +3875,89 @@ package body Sem_Ch13 is goto Continue; end Initial_Condition; + -- Initialize + + when Aspect_Initialize => Initialize : declare + Aspect_Comp : Node_Id; + Type_Comp : Node_Id; + Typ : Entity_Id; + Dummy_Aggr : Node_Id; + begin + -- Error checking + + if not All_Extensions_Allowed then + goto Continue; + end if; + + if Ekind (E) /= E_Procedure then + Error_Msg_N ("Initialize must apply to a constructor", N); + end if; + + if Present (Expressions (Expression (Aspect))) then + Error_Msg_N ("only component associations allowed", N); + end if; + + -- Install the others for the aggregate if necessary + + Typ := Etype (First_Entity (E)); + + if No (First_Entity (Typ)) then + Error_Msg_N + ("Initialize can only apply to contructors" + & " whose type has one or more components", N); + end if; + + Aspect_Comp := + First (Component_Associations (Expression (Aspect))); + Type_Comp := First_Entity (Typ); + while Present (Type_Comp) loop + if No (Aspect_Comp) then + Append_To + (Component_Associations (Expression (Aspect)), + Make_Component_Association (Loc, + Choices => + New_List (Make_Others_Choice (Loc)), + Box_Present => True)); + exit; + elsif Nkind (First (Choices (Aspect_Comp))) + = N_Others_Choice + then + exit; + end if; + + Next (Aspect_Comp); + Next_Entity (Type_Comp); + end loop; + + -- Push the scope and formals for analysis + + Push_Scope (E); + Install_Formals (Defining_Unit_Name (Specification (N))); + + -- Analyze the components + + Aspect_Comp := + First (Component_Associations (Expression (Aspect))); + while Present (Aspect_Comp) loop + if Present (Expression (Aspect_Comp)) then + Analyze (Expression (Aspect_Comp)); + end if; + + Next (Aspect_Comp); + end loop; + + -- Do a psuedo pass over the aggregate to ensure it is valid + + Expander_Active := False; + Dummy_Aggr := New_Copy_Tree (Expression (Aspect)); + Resolve_Aggregate (Dummy_Aggr, Typ); + Expander_Active := True; + + -- Return the scope + + End_Scope; + end Initialize; + -- Initializes -- Aspect Initializes is never delayed because it is equivalent @@ -4346,6 +4431,10 @@ package body Sem_Ch13 is Analyze_Aspect_Implicit_Dereference; goto Continue; + when Aspect_Constructor => + Set_Constructor_Name (E, Expr); + Set_Needs_Construction (E); + -- Dimension when Aspect_Dimension => @@ -4366,8 +4455,9 @@ package body Sem_Ch13 is -- Case 4: Aspects requiring special handling -- Pre/Post/Test_Case/Contract_Cases/Always_Terminates/ - -- Exceptional_Cases/Exit_Cases and Subprogram_Variant whose - -- corresponding pragmas take care of the delay. + -- Exceptional_Cases/Exit_Cases/Program_Exit and + -- Subprogram_Variant whose corresponding pragmas take care of + -- the delay. -- Pre/Post @@ -4573,6 +4663,19 @@ package body Sem_Ch13 is Insert_Pragma (Aitem); goto Continue; + -- Program_Exit + + when Aspect_Program_Exit => + Aitem := Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Program_Exit); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + -- Subprogram_Variant when Aspect_Subprogram_Variant => @@ -6278,11 +6381,6 @@ package body Sem_Ch13 is then Set_Check_Address_Alignment (N); end if; - - -- Kill the size check code, since we are not allocating - -- the variable, it is somewhere else. - - Kill_Size_Check_Code (U_Ent); end; -- Not a valid entity for an address clause @@ -6502,7 +6600,8 @@ package body Sem_Ch13 is -- and restored before and after analysis. Push_Type (U_Ent); - Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); + Preanalyze_And_Resolve_Spec_Expression + (Expr, RTE (RE_CPU_Range)); Pop_Type (U_Ent); -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU": @@ -6592,10 +6691,8 @@ package body Sem_Ch13 is -- The visibility to the components must be restored Push_Type (U_Ent); - - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Expr, RTE (RE_Dispatching_Domain)); - Pop_Type (U_Ent); end if; @@ -6674,10 +6771,8 @@ package body Sem_Ch13 is -- The visibility to the components must be restored Push_Type (U_Ent); - - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Expr, RTE (RE_Interrupt_Priority)); - Pop_Type (U_Ent); -- Check the No_Task_At_Interrupt_Priority restriction @@ -6843,7 +6938,8 @@ package body Sem_Ch13 is -- The visibility to the components must be restored Push_Type (U_Ent); - Preanalyze_Spec_Expression (Expr, Standard_Integer); + Preanalyze_And_Resolve_Spec_Expression + (Expr, Standard_Integer); Pop_Type (U_Ent); if not Is_OK_Static_Expression (Expr) then @@ -7154,7 +7250,7 @@ package body Sem_Ch13 is else Small := Expr_Value_R (Expr); - if Small <= Ureal_0 then + if not UR_Is_Positive (Small) then Error_Msg_N ("small value must be greater than zero", Expr); return; end if; @@ -10039,8 +10135,8 @@ package body Sem_Ch13 is -- If the predicate pragma comes from an aspect, replace the -- saved expression because we need the subtype references - -- replaced for the calls to Preanalyze_Spec_Expression in - -- Check_Aspect_At_xxx routines. + -- replaced for the calls to Preanalyze_And_Resolve_Spec_ + -- Expression in Check_Aspect_At_xxx routines. if Present (Asp) then Set_Expression_Copy (Asp, New_Copy_Tree (Arg2_Copy)); @@ -10806,7 +10902,8 @@ package body Sem_Ch13 is -- name, so we need to verify that one of these interpretations is -- the one available at at the freeze point. - elsif A_Id in Aspect_Input + elsif A_Id in Aspect_Constructor + | Aspect_Input | Aspect_Output | Aspect_Read | Aspect_Write @@ -10853,12 +10950,14 @@ package body Sem_Ch13 is | Aspect_Static_Predicate then Push_Type (Ent); - Preanalyze_Spec_Expression (Freeze_Expr, Standard_Boolean); + Preanalyze_And_Resolve_Spec_Expression + (Freeze_Expr, Standard_Boolean); Pop_Type (Ent); elsif A_Id = Aspect_Priority then Push_Type (Ent); - Preanalyze_Spec_Expression (Freeze_Expr, Any_Integer); + Preanalyze_And_Resolve_Spec_Expression + (Freeze_Expr, Any_Integer); Pop_Type (Ent); else @@ -10908,7 +11007,8 @@ package body Sem_Ch13 is elsif A_Id in Aspect_Default_Component_Value | Aspect_Default_Value and then Is_Private_Type (T) then - Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T)); + Preanalyze_And_Resolve_Spec_Expression + (End_Decl_Expr, Full_View (T)); -- The following aspect expressions may contain references to -- components and discriminants of the type. @@ -10922,14 +11022,15 @@ package body Sem_Ch13 is | Aspect_Static_Predicate then Push_Type (Ent); - Preanalyze_Spec_Expression (End_Decl_Expr, T); + Preanalyze_And_Resolve_Spec_Expression (End_Decl_Expr, T); Pop_Type (Ent); elsif A_Id = Aspect_Predicate_Failure then - Preanalyze_Spec_Expression (End_Decl_Expr, Standard_String); + Preanalyze_And_Resolve_Spec_Expression + (End_Decl_Expr, Standard_String); elsif Present (End_Decl_Expr) then - Preanalyze_Spec_Expression (End_Decl_Expr, T); + Preanalyze_And_Resolve_Spec_Expression (End_Decl_Expr, T); end if; Err := @@ -11112,7 +11213,8 @@ package body Sem_Ch13 is -- Special case, the expression of these aspects is just an entity -- that does not need any resolution, so just analyze. - when Aspect_Input + when Aspect_Constructor + | Aspect_Input | Aspect_Output | Aspect_Put_Image | Aspect_Read @@ -11324,6 +11426,7 @@ package body Sem_Ch13 is | Aspect_GNAT_Annotate | Aspect_Implicit_Dereference | Aspect_Initial_Condition + | Aspect_Initialize | Aspect_Initializes | Aspect_Max_Entry_Queue_Length | Aspect_Max_Queue_Length @@ -11333,6 +11436,7 @@ package body Sem_Ch13 is | Aspect_Postcondition | Aspect_Pre | Aspect_Precondition + | Aspect_Program_Exit | Aspect_Refined_Depends | Aspect_Refined_Global | Aspect_Refined_Post @@ -11359,7 +11463,7 @@ package body Sem_Ch13 is -- the aspect_specification cause freezing (RM 13.14(7.2/5)). if Present (Expression (ASN)) then - Preanalyze_Spec_Expression (Expression (ASN), T); + Preanalyze_And_Resolve_Spec_Expression (Expression (ASN), T); end if; end Check_Aspect_At_Freeze_Point; @@ -12082,18 +12186,15 @@ package body Sem_Ch13 is if not Check_Primitive_Function (Subp, Typ) then if Present (Ref_Node) then - if Debug_Flag_Underscore_DD then - Record_Default_Iterator_Not_Primitive_Error - (Ref_Node, Subp); - else - Error_Msg_N ("improper function for default iterator!", - Ref_Node); - Error_Msg_Sloc := Sloc (Subp); - Error_Msg_NE - ("\\default iterator defined # " - & "must be a local primitive or class-wide function", - Ref_Node, Subp); - end if; + Error_Msg_N + ("improper function for default iterator!", + Ref_Node, + GNAT0001); + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_NE + ("\\default iterator defined # " + & "must be a local primitive or class-wide function", + Ref_Node, Subp); end if; return False; @@ -13928,7 +14029,7 @@ package body Sem_Ch13 is Next (First (Pragma_Argument_Associations (Ritem))); begin Push_Type (E); - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Expression (Arg), Standard_Boolean); Pop_Type (E); end; @@ -15786,27 +15887,36 @@ package body Sem_Ch13 is -- anyway, no reason to be too strict about this. if not Relaxed_RM_Semantics then - if Debug_Flag_Underscore_DD then - - S := First_Subtype (T); - if Present (Freeze_Node (S)) then - Record_Representation_Too_Late_Error - (Rep => N, - Freeze => Freeze_Node (S), - Def => S); - else - Error_Msg_N ("|representation item appears too late!", N); - end if; - + S := First_Subtype (T); + if Present (Freeze_Node (S)) then + Error_Msg_N + (Msg => + "record representation cannot be specified" & + " after the type is frozen", + N => N, + Error_Code => GNAT0005, + Label => + "record representation clause specified here", + Spans => + (1 => + Secondary_Labeled_Span + (N => Freeze_Node (S), + Label => + "Type " & To_Name (S) & + " is frozen here"), + 2 => + Secondary_Labeled_Span + (N => S, + Label => + "Type " & To_Name (S) & + " is declared here"))); + Error_Msg_Sloc := Sloc (Freeze_Node (S)); + Error_Msg_N + ("\\move the record representation clause" & + " before the freeze point #", + N); else Error_Msg_N ("|representation item appears too late!", N); - - S := First_Subtype (T); - if Present (Freeze_Node (S)) then - Error_Msg_NE - ("??no more representation items for }", - Freeze_Node (S), S); - end if; end if; end if; end Too_Late; @@ -16345,6 +16455,9 @@ package body Sem_Ch13 is => null; + when Aspect_Constructor => + null; + when Aspect_Dynamic_Predicate | Aspect_Ghost_Predicate | Aspect_Predicate diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 74eac9c..690d668 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -41,7 +41,6 @@ with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Expander; use Expander; with Fmap; with Freeze; use Freeze; with Ghost; use Ghost; @@ -623,9 +622,11 @@ package body Sem_Ch3 is -- Create a new ordinary fixed point type, and apply the constraint to -- obtain subtype of it. - procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); - -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that - -- In_Default_Expr can be properly adjusted. + procedure Preanalyze_And_Resolve_Default_Expression + (N : Node_Id; + T : Entity_Id); + -- Wrapper on Preanalyze_And_Resolve_Spec_Expression for default + -- expressions, so that In_Default_Expr can be properly adjusted. procedure Prepare_Private_Subtype_Completion (Id : Entity_Id; @@ -1307,14 +1308,6 @@ package body Sem_Ch3 is Reinit_Size_Align (T_Name); Set_Directly_Designated_Type (T_Name, Desig_Type); - -- If the access_to_subprogram is not declared at the library level, - -- it can only point to subprograms that are at the same or deeper - -- accessibility level. The corresponding subprogram type might - -- require an activation record when compiling for C. - - Set_Needs_Activation_Record (Desig_Type, - not Is_Library_Level_Entity (T_Name)); - Generate_Reference_To_Formals (T_Name); -- Ada 2005 (AI-231): Propagate the null-excluding attribute @@ -2110,7 +2103,7 @@ package body Sem_Ch3 is -- package Sem). if Present (E) then - Preanalyze_Default_Expression (E, T); + Preanalyze_And_Resolve_Default_Expression (E, T); Check_Initialization (T, E); if Ada_Version >= Ada_2005 @@ -2507,7 +2500,8 @@ package body Sem_Ch3 is (First (Pragma_Argument_Associations (ASN)))); Set_Parent (Exp, ASN); - Preanalyze_Assert_Expression (Exp, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Exp, Standard_Boolean); end if; ASN := Next_Pragma (ASN); @@ -3200,7 +3194,7 @@ package body Sem_Ch3 is and then Present (Full_View (Prev)) then T := Full_View (Prev); - Set_Incomplete_View (N, Prev); + Set_Incomplete_View (T, Prev); else T := Prev; end if; @@ -3551,6 +3545,13 @@ package body Sem_Ch3 is end; end if; end if; + + if Ekind (T) = E_Record_Type + and then Is_Large_Unconstrained_Definite (T) + and then not Is_Limited_Type (T) + then + Error_Msg_N ("??creation of & object may raise Storage_Error!", T); + end if; end Analyze_Full_Type_Declaration; ---------------------------------- @@ -4991,7 +4992,7 @@ package body Sem_Ch3 is if Is_Array_Type (T) and then No_Initialization (N) - and then Nkind (Original_Node (E)) = N_Aggregate + and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate then Act_T := Etype (E); @@ -5137,10 +5138,7 @@ package body Sem_Ch3 is elsif Is_Array_Type (T) and then No_Initialization (N) - and then (Nkind (Original_Node (E)) = N_Aggregate - or else (Nkind (Original_Node (E)) = N_Qualified_Expression - and then Nkind (Original_Node (Expression - (Original_Node (E)))) = N_Aggregate)) + and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate then if not Is_Entity_Name (Object_Definition (N)) then Act_T := Etype (E); @@ -6633,8 +6631,6 @@ package body Sem_Ch3 is end; end if; - -- Constrained array case - if No (T) then -- We might be creating more than one itype with the same Related_Id, -- e.g. for an array object definition and its initial value. Give @@ -6644,6 +6640,8 @@ package body Sem_Ch3 is T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1); end if; + -- Constrained array case + if Nkind (Def) = N_Constrained_Array_Definition then Index := First (Discrete_Subtype_Definitions (Def)); @@ -11985,7 +11983,7 @@ package body Sem_Ch3 is Insert_Before (Typ_Decl, Decl); Analyze (Decl); Set_Full_View (Inc_T, Typ); - Set_Incomplete_View (Typ_Decl, Inc_T); + Set_Incomplete_View (Typ, Inc_T); -- If the type is tagged, create a common class-wide type for -- both views, and set the Etype of the class-wide type to the @@ -20857,67 +20855,71 @@ package body Sem_Ch3 is Set_Is_Constrained (T); end Ordinary_Fixed_Point_Type_Declaration; - ---------------------------------- - -- Preanalyze_Assert_Expression -- - ---------------------------------- + ---------------------------------------------- + -- Preanalyze_And_Resolve_Assert_Expression -- + ---------------------------------------------- - procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is + procedure Preanalyze_And_Resolve_Assert_Expression + (N : Node_Id; + T : Entity_Id) is begin In_Assertion_Expr := In_Assertion_Expr + 1; - Preanalyze_Spec_Expression (N, T); + Preanalyze_And_Resolve_Spec_Expression (N, T); In_Assertion_Expr := In_Assertion_Expr - 1; - end Preanalyze_Assert_Expression; + end Preanalyze_And_Resolve_Assert_Expression; - -- ??? The variant below explicitly saves and restores all the flags, - -- because it is impossible to compose the existing variety of - -- Analyze/Resolve (and their wrappers, e.g. Preanalyze_Spec_Expression) - -- to achieve the desired semantics. - - procedure Preanalyze_Assert_Expression (N : Node_Id) is - Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; - Save_Full_Analysis : constant Boolean := Full_Analysis; + ---------------------------------------------- + -- Preanalyze_And_Resolve_Assert_Expression -- + ---------------------------------------------- + procedure Preanalyze_And_Resolve_Assert_Expression (N : Node_Id) is begin In_Assertion_Expr := In_Assertion_Expr + 1; - In_Spec_Expression := True; - Full_Analysis := False; - Expander_Mode_Save_And_Set (False); - - if GNATprove_Mode then - Analyze_And_Resolve (N); - else - Analyze_And_Resolve (N, Suppress => All_Checks); - end if; - - Expander_Mode_Restore; - Full_Analysis := Save_Full_Analysis; - In_Spec_Expression := Save_In_Spec_Expression; + Preanalyze_And_Resolve_Spec_Expression (N); In_Assertion_Expr := In_Assertion_Expr - 1; - end Preanalyze_Assert_Expression; + end Preanalyze_And_Resolve_Assert_Expression; - ----------------------------------- - -- Preanalyze_Default_Expression -- - ----------------------------------- + ----------------------------------------------- + -- Preanalyze_And_Resolve_Default_Expression -- + ----------------------------------------------- - procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is + procedure Preanalyze_And_Resolve_Default_Expression + (N : Node_Id; + T : Entity_Id) + is Save_In_Default_Expr : constant Boolean := In_Default_Expr; begin In_Default_Expr := True; - Preanalyze_Spec_Expression (N, T); + Preanalyze_And_Resolve_Spec_Expression (N, T); In_Default_Expr := Save_In_Default_Expr; - end Preanalyze_Default_Expression; + end Preanalyze_And_Resolve_Default_Expression; - -------------------------------- - -- Preanalyze_Spec_Expression -- - -------------------------------- + -------------------------------------------- + -- Preanalyze_And_Resolve_Spec_Expression -- + -------------------------------------------- - procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is + procedure Preanalyze_And_Resolve_Spec_Expression + (N : Node_Id; + T : Entity_Id) + is Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; begin In_Spec_Expression := True; Preanalyze_And_Resolve (N, T); In_Spec_Expression := Save_In_Spec_Expression; - end Preanalyze_Spec_Expression; + end Preanalyze_And_Resolve_Spec_Expression; + + -------------------------------------------- + -- Preanalyze_And_Resolve_Spec_Expression -- + -------------------------------------------- + + procedure Preanalyze_And_Resolve_Spec_Expression (N : Node_Id) is + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin + In_Spec_Expression := True; + Preanalyze_And_Resolve (N); + In_Spec_Expression := Save_In_Spec_Expression; + end Preanalyze_And_Resolve_Spec_Expression; ---------------------------------------- -- Prepare_Private_Subtype_Completion -- @@ -21076,7 +21078,8 @@ package body Sem_Ch3 is -- Per-Object Expressions" in spec of package Sem). if Present (Expression (Discr)) then - Preanalyze_Default_Expression (Expression (Discr), Discr_Type); + Preanalyze_And_Resolve_Default_Expression + (Expression (Discr), Discr_Type); -- Legaity checks @@ -23141,6 +23144,14 @@ package body Sem_Ch3 is Propagate_Concurrent_Flags (T, Etype (Component)); + -- Propagate information about constructor dependence + + if Ekind (Etype (Component)) /= E_Void + and then Needs_Construction (Etype (Component)) + then + Set_Needs_Construction (T); + end if; + if Ekind (Component) /= E_Component then null; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 3d9aa0a..00a6fa77 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -236,19 +236,23 @@ package Sem_Ch3 is -- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in -- Ada 2005 mode. - procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id); - -- Wrapper on Preanalyze_Spec_Expression for assertion expressions, so that - -- In_Assertion_Expr can be properly adjusted. + procedure Preanalyze_And_Resolve_Assert_Expression + (N : Node_Id; + T : Entity_Id); + -- Wrapper on Preanalyze_And_Resolve_Spec_Expression for assertion + -- expressions, so that In_Assertion_Expr can be properly adjusted. -- -- This routine must not be called when N is the root of a subtree that is -- not in its final place since it freezes static expression entities, -- which would be misplaced in the tree. Preanalyze_And_Resolve must be -- used in such a case to avoid reporting spurious errors. - procedure Preanalyze_Assert_Expression (N : Node_Id); + procedure Preanalyze_And_Resolve_Assert_Expression (N : Node_Id); -- Similar to the above, but without forcing N to be of a particular type - procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id); + procedure Preanalyze_And_Resolve_Spec_Expression + (N : Node_Id; + T : Entity_Id); -- 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 @@ -263,6 +267,9 @@ package Sem_Ch3 is -- which would be misplaced in the tree. Preanalyze_And_Resolve must be -- used in such a case to avoid reporting spurious errors. + procedure Preanalyze_And_Resolve_Spec_Expression (N : Node_Id); + -- Similar to the above, but without forcing N to be of a particular type + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is -- encountered and analyzed. The first action is to create the full views diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 4069839..9a1784f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -27,11 +27,11 @@ with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; -with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; +with Errid; use Errid; with Errout; use Errout; with Exp_Util; use Exp_Util; with Itypes; use Itypes; @@ -308,8 +308,12 @@ package body Sem_Ch4 is (N : Node_Id; Prefix : Node_Id; Exprs : List_Id) return Boolean; - -- AI05-0139: Generalized indexing to support iterators over containers - -- ??? Need to provide a more detailed spec of what this function does + -- AI05-0139: Generalized indexing to support iterators over containers. + -- Given the N_Indexed_Component node N, with the given prefix and + -- expressions list, check if the generalized indexing is applicable; + -- if applicable then build its indexing function, link it to N through + -- attribute Generalized_Indexing, and return True; otherwise return + -- False. function Try_Indexed_Call (N : Node_Id; @@ -6040,9 +6044,10 @@ package body Sem_Ch4 is Error_Msg_NE ("invalid prefix in selected component&", N, Sel); end if; - -- If N still has no type, the component is not defined in the prefix + -- If the selector is not labelled with an entity at this point, the + -- component is not defined in the prefix. - if Etype (N) = Any_Type then + if No (Entity (Sel)) then if Is_Single_Concurrent_Object then Error_Msg_Node_2 := Entity (Pref); @@ -7642,35 +7647,14 @@ package body Sem_Ch4 is begin if not Is_Overloaded (R) then if Is_Numeric_Type (Etype (R)) then - - -- In an instance a generic actual may be a numeric type even if - -- the formal in the generic unit was not. In that case, the - -- predefined operator was not a possible interpretation in the - -- generic, and cannot be one in the instance, unless the operator - -- is an actual of an instance. - - if In_Instance - and then - not Is_Numeric_Type (Corresponding_Generic_Type (Etype (R))) - then - null; - else - Add_One_Interp (N, Op_Id, Base_Type (Etype (R))); - end if; + Add_One_Interp (N, Op_Id, Base_Type (Etype (R))); end if; else Get_First_Interp (R, Index, It); while Present (It.Typ) loop if Is_Numeric_Type (It.Typ) then - if In_Instance - and then - not Is_Numeric_Type - (Corresponding_Generic_Type (Etype (It.Typ))) - then - null; - - elsif Is_Effectively_Visible_Operator (N, Base_Type (It.Typ)) + if Is_Effectively_Visible_Operator (N, Base_Type (It.Typ)) then Add_One_Interp (N, Op_Id, Base_Type (It.Typ)); end if; @@ -8533,21 +8517,29 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean is - Pref_Typ : Entity_Id := Etype (Prefix); + Heuristic : Boolean := False; + Pref_Typ : Entity_Id := Etype (Prefix); function Constant_Indexing_OK return Boolean; - -- Constant_Indexing is legal if there is no Variable_Indexing defined - -- for the type, or else node not a target of assignment, or an actual - -- for an IN OUT or OUT formal (RM 4.1.6 (11)). - - function Expr_Matches_In_Formal - (Subp : Entity_Id; - Par : Node_Id) return Boolean; - -- Find formal corresponding to given indexed component that is an - -- actual in a call. Note that the enclosing subprogram call has not - -- been analyzed yet, and the parameter list is not normalized, so - -- that if the argument is a parameter association we must match it - -- by name and not by position. + -- Determines whether the Constant_Indexing aspect has been specified + -- for the type of the prefix and can be interpreted as constant + -- indexing; that is, there is no Variable_Indexing defined for the + -- type, or else the node is not a target of an assignment, or an + -- actual for an IN OUT or OUT formal, or the name in an object + -- renaming (RM 4.1.6 (12/3..15/3)). + -- + -- Given that prefix notation calls have not yet been resolved, if the + -- type of the prefix has both aspects present (Constant_Indexing and + -- Variable_Indexing), and context analysis performed by this routine + -- identifies a potential prefix notation call (i.e., an N_Selected_ + -- Component node), this function may rely on heuristics to decide + -- between constant or variable indexing. In such cases, if the + -- decision is later found to be incorrect, Try_Container_Indexing + -- will retry using the alternative indexing aspect. + + -- When heuristics are used to compute the result of this function + -- the behavior of Try_Container_Indexing might not be strictly + -- following the rules of the RM. function Indexing_Interpretations (T : Entity_Id; @@ -8555,59 +8547,429 @@ package body Sem_Ch4 is -- Return a set of interpretations reflecting all of the functions -- associated with an indexing aspect of type T of the given kind. + function Try_Indexing_Function + (Func_Name : Node_Id; + Assoc : List_Id) return Entity_Id; + -- Build a call to the given indexing function name with the given + -- parameter associations; if there are several indexing functions + -- the call is analyzed for each of the interpretation; if there are + -- several successfull candidates, resolution is handled by result. + -- Return the Etype of the built function call. + -------------------------- -- Constant_Indexing_OK -- -------------------------- function Constant_Indexing_OK return Boolean is - Par : Node_Id; + + function Expr_Matches_In_Formal + (Subp : Entity_Id; + Subp_Call : Node_Id; + Param : Node_Id; + Skip_Controlling_Formal : Boolean := False) return Boolean; + -- Find formal corresponding to given indexed component that is an + -- actual in a call. Note that the enclosing subprogram call has not + -- been analyzed yet, and the parameter list is not normalized, so + -- that if the argument is a parameter association we must match it + -- by name and not by position. In the traversal up the tree done by + -- Constant_Indexing_OK, the previous node in the traversal (that is, + -- the actual parameter used to ascend to the subprogram call node), + -- is passed to this function in formal Param, and it is used to + -- determine wether the argument is passed by name or by position. + -- Skip_Controlling_Formal is set to True to skip the first formal + -- of Subp. + + procedure Handle_Selected_Component + (Current_Node : Node_Id; + Sel_Comp : Node_Id; + Candidate : out Entity_Id; + Is_Constant_Idx : out Boolean); + -- Current_Node is the current node climbing up the tree. Determine + -- if Sel_Comp is a candidate for a prefixed call using constant + -- indexing; if no candidate is found Candidate is returned Empty + -- and Is_Constant_Idx is returned False. + + function Has_IN_Mode (Formal : Node_Id) return Boolean is + (Ekind (Formal) = E_In_Parameter); + -- Return True if the given formal has mode IN + + ---------------------------- + -- Expr_Matches_In_Formal -- + ---------------------------- + + function Expr_Matches_In_Formal + (Subp : Entity_Id; + Subp_Call : Node_Id; + Param : Node_Id; + Skip_Controlling_Formal : Boolean := False) return Boolean + is + pragma Assert (Nkind (Subp_Call) in N_Subprogram_Call); + + Actual : Node_Id := First (Parameter_Associations (Subp_Call)); + Formal : Node_Id := First_Formal (Subp); + + begin + if Skip_Controlling_Formal then + Next_Formal (Formal); + end if; + + -- Match by position + + if Nkind (Param) /= N_Parameter_Association then + while Present (Actual) and then Present (Formal) loop + exit when Actual = Param; + Next (Actual); + + if Present (Formal) then + Next_Formal (Formal); + + -- Otherwise this is a parameter mismatch, the error is + -- reported elsewhere, or else variable indexing is implied. + + else + return False; + end if; + end loop; + + -- Match by name + + else + while Present (Formal) loop + exit when Chars (Formal) = Chars (Selector_Name (Param)); + Next_Formal (Formal); + + if No (Formal) then + return False; + end if; + end loop; + end if; + + return Present (Formal) and then Has_IN_Mode (Formal); + end Expr_Matches_In_Formal; + + ------------------------------- + -- Handle_Selected_Component -- + ------------------------------- + + procedure Handle_Selected_Component + (Current_Node : Node_Id; + Sel_Comp : Node_Id; + Candidate : out Entity_Id; + Is_Constant_Idx : out Boolean) + is + procedure Search_Constant_Interpretation + (Call : Node_Id; + Target_Name : Node_Id; + Candidate : out Entity_Id; + Is_Unique : out Boolean; + Unique_Mode : out Boolean); + -- Given a subprogram call, search in the homonyms chain for + -- visible (or potentially visible) dispatching primitives that + -- have at least one formal. Candidate is the entity of the first + -- found candidate; Is_Unique is returned True when the mode of + -- the first formal of all the candidates match. If no candidate + -- is found the out parameter Candidate is returned Empty, and + -- Is_Unique is returned False. + + procedure Search_Enclosing_Call + (Call_Node : out Node_Id; + Prev_Node : out Node_Id); + -- Climb up to the tree looking for an enclosing subprogram call + -- of a prefixed notation call. If found then the Call_Node and + -- its Prev_Node in such traversal are returned; otherwise + -- Call_Node and Prev_Node are returned Empty. + + ------------------------------------ + -- Search_Constant_Interpretation -- + ------------------------------------ + + procedure Search_Constant_Interpretation + (Call : Node_Id; + Target_Name : Node_Id; + Candidate : out Entity_Id; + Is_Unique : out Boolean; + Unique_Mode : out Boolean) + is + Constant_Idx : Boolean; + In_Proc_Call : constant Boolean := + Present (Call) + and then + Nkind (Call) = N_Procedure_Call_Statement; + Kind : constant Entity_Kind := + (if In_Proc_Call then E_Procedure + else E_Function); + Target_Subp : constant Entity_Id := + Current_Entity (Target_Name); + begin + Candidate := Empty; + Is_Unique := False; + Unique_Mode := False; + + if Present (Target_Subp) then + declare + Hom : Entity_Id := Target_Subp; + + begin + while Present (Hom) loop + if Is_Overloadable (Hom) + and then Is_Dispatching_Operation (Hom) + and then + (Is_Immediately_Visible (Scope (Hom)) + or else + Is_Potentially_Use_Visible (Scope (Hom))) + and then Ekind (Hom) = Kind + and then Present (First_Formal (Hom)) + then + if No (Candidate) then + Candidate := Hom; + Is_Unique := True; + Unique_Mode := True; + Constant_Idx := + Has_IN_Mode (First_Formal (Candidate)); + + else + Is_Unique := False; + + if Ekind (First_Formal (Hom)) + /= Ekind (First_Formal (Candidate)) + or else Has_IN_Mode (First_Formal (Hom)) + /= Constant_Idx + then + Unique_Mode := False; + exit; + end if; + end if; + end if; + + Hom := Homonym (Hom); + end loop; + end; + end if; + end Search_Constant_Interpretation; + + --------------------------- + -- Search_Enclosing_Call -- + --------------------------- + + procedure Search_Enclosing_Call + (Call_Node : out Node_Id; + Prev_Node : out Node_Id) + is + Prev : Node_Id := Current_Node; + Par : Node_Id := Parent (N); + + begin + while Present (Par) + and then Nkind (Par) not in N_Subprogram_Call + | N_Handled_Sequence_Of_Statements + | N_Assignment_Statement + | N_Iterator_Specification + | N_Object_Declaration + | N_Case_Statement + | N_Declaration + | N_Elsif_Part + | N_If_Statement + | N_Simple_Return_Statement + loop + Prev := Par; + Par := Parent (Par); + end loop; + + if Present (Par) + and then Nkind (Par) in N_Subprogram_Call + and then Nkind (Name (Par)) = N_Selected_Component + then + Call_Node := Par; + Prev_Node := Prev; + else + Call_Node := Empty; + Prev_Node := Empty; + end if; + end Search_Enclosing_Call; + + -- Local variables + + Is_Unique : Boolean; + Unique_Mode : Boolean; + Call_Node : Node_Id; + Prev_Node : Node_Id; + + -- Start of processing for Handle_Selected_Component + + begin + pragma Assert (Nkind (Sel_Comp) = N_Selected_Component); + + -- Climb up the tree starting from Current_Node searching for the + -- enclosing subprogram call of a prefixed notation call. + + Search_Enclosing_Call (Call_Node, Prev_Node); + + -- Search for a candidate visible (or potentially visible) + -- dispatching primitive that has at least one formal, and may + -- be called using the prefix notation. This must be done even + -- if we did not found an enclosing call since the prefix notation + -- call has not been transformed yet into a subprogram call. The + -- found Call_Node (if any) is passed now to help identifying if + -- the prefix notation call corresponds with a procedure call or + -- a function call. + + Search_Constant_Interpretation + (Call => Call_Node, + Target_Name => Selector_Name (Sel_Comp), + Candidate => Candidate, + Is_Unique => Is_Unique, + Unique_Mode => Unique_Mode); + + -- If there is no candidate to interpret this node as a prefixed + -- call to a subprogram we return no candidate, and the caller + -- will continue ascending in the tree. + + if No (Candidate) then + Is_Constant_Idx := False; + + -- If we found an unique candidate and also found the enclosing + -- call node, we differentiate two cases: either we climbed up + -- the tree through the first actual parameter of the call (that + -- is, the name of the selected component), or we climbed up the + -- tree though another actual parameter of the prefixed call and + -- we must skip the controlling formal of the call. + + elsif Is_Unique + and then Present (Call_Node) + then + -- First actual parameter + + if Name (Call_Node) = Prev_Node + and then Nkind (Prev_Node) = N_Selected_Component + and then Nkind (Selector_Name (Prev_Node)) in N_Has_Chars + and then Chars (Selector_Name (Prev_Node)) = Chars (Candidate) + then + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + + -- Any other actual parameter + + else + Is_Constant_Idx := + Expr_Matches_In_Formal (Candidate, + Subp_Call => Call_Node, + Param => Prev_Node, + Skip_Controlling_Formal => True); + end if; + + -- The mode of the first formal of all the candidates match but, + -- given that we have several candidates, we cannot check if + -- indexing is used in the first actual parameter of the call + -- or in another actual parameter. Heuristically assume here + -- that indexing is used in the prefix of a call. + + elsif Unique_Mode then + Heuristic := True; + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + + -- The target candidate subprogram has several possible + -- interpretations; we don't know what to do with an + -- N_Selected_Component node for a prefixed notation call + -- to AA.BB that has several candidate targets and it has + -- not yet been resolved. For now we maintain the + -- behavior that we have had so far; to be improved??? + + else + Heuristic := True; + + if Nkind (Call_Node) = N_Procedure_Call_Statement then + Is_Constant_Idx := False; + + -- For function calls we rely on the mode of the + -- first formal of the first found candidate??? + + else + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + end if; + end if; + end Handle_Selected_Component; + + -- Local variables + + Asp_Constant : constant Node_Id := + Find_Value_Of_Aspect (Pref_Typ, + Aspect_Constant_Indexing); + Asp_Variable : constant Node_Id := + Find_Value_Of_Aspect (Pref_Typ, + Aspect_Variable_Indexing); + Par : Node_Id; + + -- Start of processing for Constant_Indexing_OK begin - if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then + if No (Asp_Constant) then + return False; + + -- It is interpreted as constant indexing when the prefix has the + -- Constant_Indexing aspect and the Variable_Indexing aspect is not + -- specified for the type of the prefix. + + elsif No (Asp_Variable) then return True; + -- It is interpreted as constant indexing when the prefix denotes + -- a constant. + elsif not Is_Variable (Prefix) then return True; end if; + -- Both aspects are present + + pragma Assert (Present (Asp_Constant) and Present (Asp_Variable)); + + -- The prefix must be interpreted as a constant indexing when it + -- is used within a primary where a name denoting a constant is + -- permitted. + Par := N; while Present (Par) loop - if Nkind (Parent (Par)) = N_Assignment_Statement - and then Par = Name (Parent (Par)) + + -- Avoid climbing more than needed + + exit when Nkind (Parent (Par)) in N_Iterator_Specification + | N_Handled_Sequence_Of_Statements; + + if Nkind (Parent (Par)) in N_Case_Statement + | N_Declaration + | N_Elsif_Part + | N_If_Statement + | N_Simple_Return_Statement then - return False; + return True; + + -- It is not interpreted as constant indexing for the variable + -- name in the LHS of an assignment. + + elsif Nkind (Parent (Par)) = N_Assignment_Statement then + return Par /= Name (Parent (Par)); -- The call may be overloaded, in which case we assume that its -- resolution does not depend on the type of the parameter that - -- includes the indexing operation. + -- includes the indexing operation because we cannot invoke + -- Preanalyze_And_Resolve (since it would cause a never-ending + -- loop). elsif Nkind (Parent (Par)) in N_Subprogram_Call then - if not Is_Entity_Name (Name (Parent (Par))) then - - -- ??? We don't know what to do with an N_Selected_Component - -- node for a prefixed-notation call to AA.BB where AA's - -- type is known, but BB has not yet been resolved. In that - -- case, the preceding Is_Entity_Name call returns False. - -- Incorrectly returning False here will usually work - -- better than incorrectly returning True, so that's what - -- we do for now. - - return False; - end if; + -- Regular subprogram call - declare - Proc : Entity_Id; + -- It is not interpreted as constant indexing for the name + -- used for an OUT or IN OUT parameter. - begin - -- We should look for an interpretation with the proper - -- number of formals, and determine whether it is an - -- In_Parameter, but for now we examine the formal that - -- corresponds to the indexing, and assume that variable - -- indexing is required if some interpretation has an - -- assignable formal at that position. Still does not - -- cover the most complex cases ??? + -- We should look for an interpretation with the proper + -- number of formals, and determine whether it is an + -- In_Parameter, but for now we examine the formal that + -- corresponds to the indexing, and assume that variable + -- indexing is required if some interpretation has an + -- assignable formal at that position. Still does not + -- cover the most complex cases ??? + if Is_Entity_Name (Name (Parent (Par))) then if Is_Overloaded (Name (Parent (Par))) then declare Proc : constant Node_Id := Name (Parent (Par)); @@ -8617,57 +8979,103 @@ package body Sem_Ch4 is begin Get_First_Interp (Proc, I, It); while Present (It.Nam) loop - if not Expr_Matches_In_Formal (It.Nam, Par) then + if not Expr_Matches_In_Formal + (Subp => It.Nam, + Subp_Call => Parent (Par), + Param => Par) + then return False; end if; Get_Next_Interp (I, It); end loop; - end; - -- All interpretations have a matching in-mode formal + -- All interpretations have a matching in-mode formal - return True; + return True; + end; else - Proc := Entity (Name (Parent (Par))); + declare + Proc : Entity_Id := Entity (Name (Parent (Par))); - -- If this is an indirect call, get formals from - -- designated type. + begin + -- If this is an indirect call, get formals from + -- designated type. - if Is_Access_Subprogram_Type (Etype (Proc)) then - Proc := Designated_Type (Etype (Proc)); - end if; + if Is_Access_Subprogram_Type (Etype (Proc)) then + Proc := Designated_Type (Etype (Proc)); + end if; + + return Expr_Matches_In_Formal + (Subp => Proc, + Subp_Call => Parent (Par), + Param => Par); + end; end if; - return Expr_Matches_In_Formal (Proc, Par); - end; + -- Continue climbing + + elsif Nkind (Name (Parent (Par))) = N_Explicit_Dereference then + null; + + -- Not a regular call; we know that we are in a subprogram + -- call, we also know that the name of the call may be a + -- prefixed call, and we know the name of the target + -- subprogram. Search for an unique target candidate in the + -- homonym chain. + + elsif Nkind (Name (Parent (Par))) = N_Selected_Component then + declare + Candidate : Entity_Id; + Is_Constant_Idx : Boolean; + + begin + Handle_Selected_Component + (Current_Node => Par, + Sel_Comp => Name (Parent (Par)), + Candidate => Candidate, + Is_Constant_Idx => Is_Constant_Idx); + + if Present (Candidate) then + return Is_Constant_Idx; + + -- Continue climbing + + else + null; + end if; + end; + end if; + + -- It is not interpreted as constant indexing for the name in + -- an object renaming. elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then return False; - -- If the indexed component is a prefix it may be the first actual - -- of a prefixed call. Retrieve the called entity, if any, and - -- check its first formal. Determine if the context is a procedure - -- or function call. + -- If the indexed component is a prefix it may be an actual of + -- of a prefixed call. elsif Nkind (Parent (Par)) = N_Selected_Component then declare - Sel : constant Node_Id := Selector_Name (Parent (Par)); - Nam : constant Entity_Id := Current_Entity (Sel); + Candidate : Entity_Id; + Is_Constant_Idx : Boolean; begin - if Present (Nam) and then Is_Overloadable (Nam) then - if Nkind (Parent (Parent (Par))) = - N_Procedure_Call_Statement - then - return False; + Handle_Selected_Component + (Current_Node => Par, + Sel_Comp => Parent (Par), + Candidate => Candidate, + Is_Constant_Idx => Is_Constant_Idx); - elsif Ekind (Nam) = E_Function - and then Present (First_Formal (Nam)) - then - return Ekind (First_Formal (Nam)) = E_In_Parameter; - end if; + if Present (Candidate) then + return Is_Constant_Idx; + + -- Continue climbing + + else + null; end if; end; @@ -8678,61 +9086,12 @@ package body Sem_Ch4 is Par := Parent (Par); end loop; - -- In all other cases, constant indexing is legal + -- It is not interpreted as constant indexing when both aspects + -- are present (RM 4.1.6(13/3)). - return True; + return False; end Constant_Indexing_OK; - ---------------------------- - -- Expr_Matches_In_Formal -- - ---------------------------- - - function Expr_Matches_In_Formal - (Subp : Entity_Id; - Par : Node_Id) return Boolean - is - Actual : Node_Id; - Formal : Node_Id; - - begin - Formal := First_Formal (Subp); - Actual := First (Parameter_Associations ((Parent (Par)))); - - if Nkind (Par) /= N_Parameter_Association then - - -- Match by position - - while Present (Actual) and then Present (Formal) loop - exit when Actual = Par; - Next (Actual); - - if Present (Formal) then - Next_Formal (Formal); - - -- Otherwise this is a parameter mismatch, the error is - -- reported elsewhere, or else variable indexing is implied. - - else - return False; - end if; - end loop; - - else - -- Match by name - - while Present (Formal) loop - exit when Chars (Formal) = Chars (Selector_Name (Par)); - Next_Formal (Formal); - - if No (Formal) then - return False; - end if; - end loop; - end if; - - return Present (Formal) and then Ekind (Formal) = E_In_Parameter; - end Expr_Matches_In_Formal; - ------------------------------ -- Indexing_Interpretations -- ------------------------------ @@ -8782,14 +9141,127 @@ package body Sem_Ch4 is return Indexing_Func; end Indexing_Interpretations; + --------------------------- + -- Try_Indexing_Function -- + --------------------------- + + function Try_Indexing_Function + (Func_Name : Node_Id; + Assoc : List_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + Func : Entity_Id; + Indexing : Node_Id; + + begin + if not Is_Overloaded (Func_Name) then + Func := Entity (Func_Name); + + Indexing := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Func, Loc), + Parameter_Associations => Assoc); + + Set_Parent (Indexing, Parent (N)); + Set_Generalized_Indexing (N, Indexing); + Analyze (Indexing); + Set_Etype (N, Etype (Indexing)); + + -- If the return type of the indexing function is a reference + -- type, add the dereference as a possible interpretation. Note + -- that the indexing aspect may be a function that returns the + -- element type with no intervening implicit dereference, and + -- that the reference discriminant is not the first discriminant. + + if Has_Discriminants (Etype (Func)) then + Check_Implicit_Dereference (N, Etype (Func)); + end if; + + else + -- If there are multiple indexing functions, build a function + -- call and analyze it for each of the possible interpretations. + + Indexing := + Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, Chars (Func_Name)), + Parameter_Associations => Assoc); + Set_Parent (Indexing, Parent (N)); + Set_Generalized_Indexing (N, Indexing); + Set_Etype (N, Any_Type); + Set_Etype (Name (Indexing), Any_Type); + + declare + I : Interp_Index; + It : Interp; + Success : Boolean; + + begin + Get_First_Interp (Func_Name, I, It); + Set_Etype (Indexing, Any_Type); + + -- Analyze each candidate function with the given actuals + + while Present (It.Nam) loop + Analyze_One_Call (Indexing, It.Nam, False, Success); + Get_Next_Interp (I, It); + end loop; + + -- If there are several successful candidates, resolution will + -- be by result. Mark the interpretations of the function name + -- itself. + + if Is_Overloaded (Indexing) then + Get_First_Interp (Indexing, I, It); + + while Present (It.Nam) loop + Add_One_Interp (Name (Indexing), It.Nam, It.Typ); + Get_Next_Interp (I, It); + end loop; + + else + Set_Etype (Name (Indexing), Etype (Indexing)); + end if; + + -- Now add the candidate interpretations to the indexing node + -- itself, to be replaced later by the function call. + + if Is_Overloaded (Name (Indexing)) then + Get_First_Interp (Name (Indexing), I, It); + + while Present (It.Nam) loop + Add_One_Interp (N, It.Nam, It.Typ); + + -- Add dereference interpretation if the result type has + -- implicit reference discriminants. + + if Has_Discriminants (Etype (It.Nam)) then + Check_Implicit_Dereference (N, Etype (It.Nam)); + end if; + + Get_Next_Interp (I, It); + end loop; + + else + Set_Etype (N, Etype (Name (Indexing))); + + if Has_Discriminants (Etype (N)) then + Check_Implicit_Dereference (N, Etype (N)); + end if; + end if; + end; + end if; + + return Etype (Indexing); + end Try_Indexing_Function; + -- Local variables Loc : constant Source_Ptr := Sloc (N); Assoc : List_Id; C_Type : Entity_Id; - Func : Entity_Id; Func_Name : Node_Id; - Indexing : Node_Id; + Idx_Type : Entity_Id; -- Start of processing for Try_Container_Indexing @@ -8799,6 +9271,13 @@ package body Sem_Ch4 is if Present (Generalized_Indexing (N)) then return True; + + -- Old language version or unknown type require no action + + elsif Ada_Version < Ada_2012 + or else Pref_Typ = Any_Type + then + return False; end if; -- An explicit dereference needs to be created in the case of a prefix @@ -8833,8 +9312,8 @@ package body Sem_Ch4 is Func_Name := Empty; - -- The context is suitable for constant indexing, so obtain the name of - -- the indexing functions from aspect Constant_Indexing. + -- The context is suitable for constant indexing, so obtain the name + -- of the indexing functions from aspect Constant_Indexing. if Constant_Indexing_OK then Func_Name := @@ -8867,6 +9346,11 @@ package body Sem_Ch4 is else return False; end if; + + -- Handle cascaded errors + + elsif No (Entity (Func_Name)) then + return False; end if; Assoc := New_List (Relocate_Node (Prefix)); @@ -8907,110 +9391,54 @@ package body Sem_Ch4 is end loop; end; - if not Is_Overloaded (Func_Name) then - Func := Entity (Func_Name); - - -- Can happen in case of e.g. cascaded errors - - if No (Func) then - return False; - end if; - - Indexing := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Func, Loc), - Parameter_Associations => Assoc); - - Set_Parent (Indexing, Parent (N)); - Set_Generalized_Indexing (N, Indexing); - Analyze (Indexing); - Set_Etype (N, Etype (Indexing)); - - -- If the return type of the indexing function is a reference type, - -- add the dereference as a possible interpretation. Note that the - -- indexing aspect may be a function that returns the element type - -- with no intervening implicit dereference, and that the reference - -- discriminant is not the first discriminant. - - if Has_Discriminants (Etype (Func)) then - Check_Implicit_Dereference (N, Etype (Func)); - end if; - - else - -- If there are multiple indexing functions, build a function call - -- and analyze it for each of the possible interpretations. - - Indexing := - Make_Function_Call (Loc, - Name => - Make_Identifier (Loc, Chars (Func_Name)), - Parameter_Associations => Assoc); - Set_Parent (Indexing, Parent (N)); - Set_Generalized_Indexing (N, Indexing); - Set_Etype (N, Any_Type); - Set_Etype (Name (Indexing), Any_Type); - + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); + + -- Last chance handling for heuristics: Given that prefix notation + -- calls have not yet been resolved, when the type of the prefix has + -- both operational aspects present (Constant_Indexing and Variable_ + -- Indexing), and the analysis of the context identified a potential + -- prefix notation call (i.e. an N_Selected_Component node), the + -- evaluation of Constant_Indexing_OK is based on heuristics; in such + -- case, if the chosen indexing approach is noticed now to be wrong + -- we retry with the other alternative before leaving. + + -- Retrying means that the heuristic decision taken when analyzing + -- the context failed in this case, and therefore we should adjust + -- the code of Handle_Selected_Component to improve identification + -- of prefix notation calls. This last chance handling handler is + -- left here for the purpose of improving such routine because it + -- proved to be usefull for identified such cases when the function + -- Handle_Selected_Component was added. + + if Idx_Type = Any_Type and then Heuristic then declare - I : Interp_Index; - It : Interp; - Success : Boolean; + Tried_Func_Name : constant Node_Id := Func_Name; begin - Get_First_Interp (Func_Name, I, It); - Set_Etype (Indexing, Any_Type); - - -- Analyze each candidate function with the given actuals - - while Present (It.Nam) loop - Analyze_One_Call (Indexing, It.Nam, False, Success); - Get_Next_Interp (I, It); - end loop; - - -- If there are several successful candidates, resolution will - -- be by result. Mark the interpretations of the function name - -- itself. + Func_Name := + Indexing_Interpretations (C_Type, + Aspect_Constant_Indexing); - if Is_Overloaded (Indexing) then - Get_First_Interp (Indexing, I, It); - - while Present (It.Nam) loop - Add_One_Interp (Name (Indexing), It.Nam, It.Typ); - Get_Next_Interp (I, It); - end loop; + if Present (Func_Name) + and then Func_Name /= Tried_Func_Name + then + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); else - Set_Etype (Name (Indexing), Etype (Indexing)); - end if; - - -- Now add the candidate interpretations to the indexing node - -- itself, to be replaced later by the function call. - - if Is_Overloaded (Name (Indexing)) then - Get_First_Interp (Name (Indexing), I, It); - - while Present (It.Nam) loop - Add_One_Interp (N, It.Nam, It.Typ); + Func_Name := + Indexing_Interpretations (C_Type, + Aspect_Variable_Indexing); - -- Add dereference interpretation if the result type has - -- implicit reference discriminants. - - if Has_Discriminants (Etype (It.Nam)) then - Check_Implicit_Dereference (N, Etype (It.Nam)); - end if; - - Get_Next_Interp (I, It); - end loop; - - else - Set_Etype (N, Etype (Name (Indexing))); - if Has_Discriminants (Etype (N)) then - Check_Implicit_Dereference (N, Etype (N)); + if Present (Func_Name) + and then Func_Name /= Tried_Func_Name + then + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); end if; end if; end; end if; - if Etype (Indexing) = Any_Type then + if Idx_Type = Any_Type then Error_Msg_NE ("container cannot be indexed with&", N, Etype (First (Exprs))); Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); @@ -10667,86 +11095,46 @@ package body Sem_Ch4 is end loop; if No (Op_Id) then - if Debug_Flag_Underscore_DD then - if Nkind (N) /= N_Op_Concat then - 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 - Record_Invalid_Operand_Types_For_Operator_R_Int_Error - (Op => N, - L => L, - L_Type => Etype (L), - R => R, - R_Type => Etype (R)); - - elsif Nkind (N) = N_Op_Multiply - and then Is_Fixed_Point_Type (Etype (R)) - and then Is_Integer_Type (Etype (L)) - then - Record_Invalid_Operand_Types_For_Operator_L_Int_Error - (Op => N, - L => L, - L_Type => Etype (L), - R => R, - R_Type => Etype (R)); - else - Record_Invalid_Operand_Types_For_Operator_Error - (Op => N, - L => L, - L_Type => Etype (L), - R => R, - R_Type => Etype (R)); - end if; - elsif Is_Access_Type (Etype (L)) then - Record_Invalid_Operand_Types_For_Operator_L_Acc_Error - (Op => N, - L => L); - - elsif Is_Access_Type (Etype (R)) then - Record_Invalid_Operand_Types_For_Operator_R_Acc_Error - (Op => N, - R => R); - else - Record_Invalid_Operand_Types_For_Operator_General_Error - (N); - end if; - else - Error_Msg_N ("invalid operand types for operator&", N); + Error_Msg_N + ("invalid operand types for operator&", N, + GNAT0002); - if Nkind (N) /= N_Op_Concat then - Error_Msg_NE ("\left operand has}!", N, Etype (L)); - Error_Msg_NE ("\right operand has}!", N, Etype (R)); + if Nkind (N) /= N_Op_Concat then + Error_Msg_NE + ("\left operand has}!", N, Etype (L)); + Error_Msg_NE + ("\right operand has}!", N, Etype (R)); - -- For multiplication and division operators with - -- a fixed-point operand and an integer operand, - -- indicate that the integer operand should be of - -- type Integer. + -- For multiplication and division operators with + -- a fixed-point operand and an integer operand, + -- indicate that the integer operand should be of + -- type Integer. - 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 - Error_Msg_N ("\convert right operand to `Integer`", N); + 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 + Error_Msg_N + ("\convert right operand to `Integer`", N); - elsif Nkind (N) = N_Op_Multiply - and then Is_Fixed_Point_Type (Etype (R)) - and then Is_Integer_Type (Etype (L)) - then - Error_Msg_N ("\convert left operand to `Integer`", N); - end if; + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Error_Msg_N + ("\convert left operand to `Integer`", N); + end if; -- For concatenation operators it is more difficult to -- determine which is the wrong operand. It is worth -- flagging explicitly an access type, for those who -- might think that a dereference happens here. - elsif Is_Access_Type (Etype (L)) then - Error_Msg_N ("\left operand is access type", N); + elsif Is_Access_Type (Etype (L)) then + Error_Msg_N ("\left operand is access type", N); - elsif Is_Access_Type (Etype (R)) then - Error_Msg_N ("\right operand is access type", N); - end if; + elsif Is_Access_Type (Etype (R)) then + Error_Msg_N ("\right operand is access type", N); end if; end if; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 12d6426..0c2cb2c 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -534,7 +534,11 @@ package body Sem_Ch5 is if In_Inlined_Body then null; - elsif not Is_Variable (Lhs) then + elsif not Is_Variable (Lhs) + and then not (not Comes_From_Source (Lhs) + and then Nkind (Lhs) in N_Has_Etype + and then Needs_Construction (Etype (Lhs))) + then -- Ada 2005 (AI-327): Check assignment to the attribute Priority of a -- protected object. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 05bbeed..91321710 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -581,16 +581,21 @@ package body Sem_Ch6 is Set_Has_Completion (Def_Id, not Is_Ignored_Ghost_Entity (Def_Id)); Push_Scope (Def_Id); Install_Formals (Def_Id); - Preanalyze_Spec_Expression (Expr, Typ); + Preanalyze_And_Resolve_Spec_Expression (Expr, Typ); End_Scope; else Push_Scope (Def_Id); Install_Formals (Def_Id); - Preanalyze_Spec_Expression (Expr, Typ); + Preanalyze_And_Resolve_Spec_Expression (Expr, Typ); Check_Limited_Return (Orig_N, Expr, Typ); End_Scope; end if; + if Is_Incomplete_Type (Typ) then + Error_Msg_NE + ("premature usage of incomplete}", Expr, First_Subtype (Typ)); + end if; + -- In the case of an expression function marked with the aspect -- Static, we need to check the requirement that the function's -- expression is a potentially static expression. This is done @@ -617,7 +622,7 @@ package body Sem_Ch6 is begin Set_Checking_Potentially_Static_Expression (True); - Preanalyze_Spec_Expression (Exp_Copy, Typ); + Preanalyze_And_Resolve_Spec_Expression (Exp_Copy, Typ); if not Is_Static_Expression (Exp_Copy) then Error_Msg_N @@ -2270,6 +2275,23 @@ package body Sem_Ch6 is end if; Formal := First_Formal (Spec_Id); + + -- The first parameter of a borrowing traversal function might be an IN + -- or an IN OUT parameter. + + if Present (Formal) + and then Ekind (Etype (Spec_Id)) = E_Anonymous_Access_Type + and then not Is_Access_Constant (Etype (Spec_Id)) + then + if Ekind (Formal) = E_Out_Parameter then + Error_Msg_Code := GEC_Out_Parameter_In_Function; + Error_Msg_N + ("first parameter of traversal function cannot have mode `OUT` " + & "in SPARK '[[]']", Formal); + end if; + Next_Formal (Formal); + end if; + while Present (Formal) loop if Ekind (Spec_Id) in E_Function | E_Generic_Function and then not Is_Function_With_Side_Effects (Spec_Id) @@ -4581,7 +4603,7 @@ package body Sem_Ch6 is Analyze_SPARK_Subprogram_Specification (Specification (N)); -- A function with side effects shall not be an expression function - -- (SPARK RM 6.1.11(6)). + -- (SPARK RM 6.1.12(6)). if Present (Spec_Id) and then (Is_Expression_Function (Spec_Id) @@ -4644,10 +4666,8 @@ package body Sem_Ch6 is -- an incomplete tagged type declaration, get the class-wide -- type of the incomplete tagged type to match Find_Type_Name. - if Nkind (Parent (Etyp)) = N_Full_Type_Declaration - and then Present (Incomplete_View (Parent (Etyp))) - then - Etyp := Class_Wide_Type (Incomplete_View (Parent (Etyp))); + if Present (Incomplete_View (Etype (Etyp))) then + Etyp := Class_Wide_Type (Incomplete_View (Etype (Etyp))); end if; Set_Directly_Designated_Type (Etype (Spec_Id), Etyp); @@ -5379,6 +5399,89 @@ package body Sem_Ch6 is End_Scope; + -- Register the subprogram in a Constructor_List when it is a valid + -- constructor. + + if All_Extensions_Allowed + and then Present (First_Formal (Designator)) + then + + declare + First_Form_Type : constant Entity_Id := + Etype (First_Formal (Designator)); + + Construct : Elmt_Id; + begin + -- Valid constructors have a "controlling" formal of a type + -- with the Constructor aspect specified. Additionally, the + -- subprogram name must match value described by the aspect. + + -- Additionally, constructor declarations must exist within the + -- same scope as the type declaration and before the type is + -- frozen. + + -- For example: + -- + -- type Foo is null record with Constructor => Bar; + -- + -- procedure Bar (Self : in out Foo); + -- + + if Present (Constructor_Name (First_Form_Type)) + and then Current_Scope = Scope (First_Form_Type) + and then Chars (Constructor_Name (First_Form_Type)) + = Chars (Designator) + and then Ekind (Designator) = E_Procedure + and then Nkind (Parent (N)) = N_Subprogram_Declaration + then + -- If the constructor list is empty than we don't have to + -- look for duplicates - we simply create the list and + -- add it. + + if No (Constructor_List (First_Form_Type)) then + Set_Constructor_List + (First_Form_Type, New_Elmt_List (Designator)); + + -- Otherwise, we need to check the constructor hasen't + -- already been added (e.g. a specification and body) and + -- that there isn't a constructor with the same number of + -- type of formals. + + -- NOTE: The Constructor_List is sorted by the number of + -- parameters. + + else + Construct := First_Elmt + (Constructor_List (First_Form_Type)); + + -- Skip over constructors with less than the number of + -- parameters than Designator ??? + + -- Loop through the constructors looking for ones which + -- "match." + + Outter : loop + + -- When we are at the end of the constructor list we + -- know there are no matches, so it is safe to add. + + if No (Construct) then + Append_Elmt + (Designator, + Constructor_List (First_Form_Type)); + exit Outter; + end if; + + -- Loop through the formals and check the formals + -- match on type ??? + + Next_Elmt (Construct); + end loop Outter; + end if; + end if; + end; + end if; + -- The subprogram scope is pushed and popped around the processing of -- the return type for consistency with call above to Process_Formals -- (which itself can call Analyze_Return_Type), and to ensure that any @@ -6094,7 +6197,7 @@ package body Sem_Ch6 is if NewD then Push_Scope (New_Id); - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Default_Value (New_Formal), Etype (New_Formal)); End_Scope; end if; @@ -6517,7 +6620,7 @@ package body Sem_Ch6 is -- expanded, so expand now to check conformance. if NewD then - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Expression (New_Discr), New_Discr_Type); end if; @@ -13207,7 +13310,7 @@ package body Sem_Ch6 is -- Do the special preanalysis of the expression (see section on -- "Handling of Default Expressions" in the spec of package Sem). - Preanalyze_Spec_Expression (Default, Formal_Type); + Preanalyze_And_Resolve_Spec_Expression (Default, Formal_Type); -- An access to constant cannot be the default for -- an access parameter that is an access to variable. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0a9ef41..fe93288 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -77,6 +77,7 @@ with Style; with Table; with Tbuild; use Tbuild; with Uintp; use Uintp; +with Uname; use Uname; with Warnsw; use Warnsw; package body Sem_Ch8 is @@ -4300,6 +4301,44 @@ package body Sem_Ch8 is begin pragma Assert (Nkind (Clause) = N_Use_Package_Clause); + + -- Perform "use implies with" expansion (when extensions are enabled) + -- by inserting an extra with clause since redundant clauses don't + -- really matter. + + if All_Extensions_Allowed and then Is_In_Context_Clause (Clause) then + declare + Unum : Unit_Number_Type; + With_Clause : constant Node_Id := + Make_With_Clause (Sloc (Clause), + Name => New_Copy_Tree (Pack)); + begin + -- Attempt to load the unit mentioned in the use clause + + Unum := Load_Unit + (Load_Name => Get_Unit_Name (With_Clause), + Required => False, + Subunit => False, + Error_Node => Clause, + With_Node => With_Clause); + + -- Either we can't file the unit or the use clause is a + -- reference to a nested package - in that case just handle + -- the use clause normally. + + if Unum /= No_Unit then + + Set_Library_Unit (With_Clause, Cunit (Unum)); + Set_Is_Implicit_With (With_Clause); + + Analyze (With_Clause); + Expand_With_Clause + (With_Clause, Name (With_Clause), + Enclosing_Comp_Unit_Node (Clause)); + end if; + end; + end if; + Analyze (Pack); -- Verify that the package standard is not directly named in a @@ -9504,6 +9543,11 @@ package body Sem_Ch8 is and then Present (Scope (Entity (E))) then Mark_Use_Package (Scope (Entity (E))); + + -- Additionally mark the types of the formals and the return + -- types as used when dealing with an overloaded operator. + + Mark_Parameters (Entity (E)); end if; Curr := Current_Use_Clause (Base); @@ -9878,28 +9922,8 @@ package body Sem_Ch8 is procedure Premature_Usage (N : Node_Id) is Kind : constant Node_Kind := Nkind (Parent (Entity (N))); - E : Entity_Id := Entity (N); begin - -- Within an instance, the analysis of the actual for a formal object - -- does not see the name of the object itself. This is significant only - -- if the object is an aggregate, where its analysis does not do any - -- name resolution on component associations. (see 4717-008). In such a - -- case, look for the visible homonym on the chain. - - if In_Instance and then Present (Homonym (E)) then - E := Homonym (E); - while Present (E) and then not In_Open_Scopes (Scope (E)) loop - E := Homonym (E); - end loop; - - if Present (E) then - Set_Entity (N, E); - Set_Etype (N, Etype (E)); - return; - end if; - end if; - case Kind is when N_Component_Declaration => Error_Msg_N diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 71394aa..e32612e 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -28,11 +28,10 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; -with Debug; use Debug; -with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; +with Errid; use Errid; with Errout; use Errout; with Exp_Ch9; use Exp_Ch9; with Elists; use Elists; @@ -753,8 +752,6 @@ package body Sem_Ch9 is T_Name : Node_Id; begin - Tasking_Used := True; - T_Name := First (Names (N)); while Present (T_Name) loop Analyze (T_Name); @@ -790,8 +787,6 @@ package body Sem_Ch9 is procedure Analyze_Accept_Alternative (N : Node_Id) is begin - Tasking_Used := True; - if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; @@ -823,8 +818,6 @@ package body Sem_Ch9 is Task_Nam : Entity_Id := Empty; -- initialize to prevent warning begin - Tasking_Used := True; - -- Entry name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset. @@ -1064,7 +1057,6 @@ package body Sem_Ch9 is Trigger : Node_Id; begin - Tasking_Used := True; Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); @@ -1109,7 +1101,6 @@ package body Sem_Ch9 is Is_Disp_Select : Boolean := False; begin - Tasking_Used := True; Check_Restriction (No_Select_Statements, N); -- Ada 2005 (AI-345): The trigger may be a dispatching call @@ -1154,7 +1145,6 @@ package body Sem_Ch9 is Typ : Entity_Id; begin - Tasking_Used := True; Check_Restriction (No_Delay, N); if Present (Pragmas_Before (N)) then @@ -1206,7 +1196,6 @@ package body Sem_Ch9 is E : constant Node_Id := Expression (N); begin - Tasking_Used := True; Check_Restriction (No_Relative_Delay, N); Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); @@ -1231,7 +1220,6 @@ package body Sem_Ch9 is Typ : Entity_Id; begin - Tasking_Used := True; Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); Analyze_And_Resolve (E); @@ -1266,8 +1254,6 @@ package body Sem_Ch9 is Freeze_Previous_Contracts (N); - Tasking_Used := True; - -- Entry_Name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset. @@ -1518,8 +1504,6 @@ package body Sem_Ch9 is Formals : constant List_Id := Parameter_Specifications (N); begin - Tasking_Used := True; - if Present (Index) then Analyze (Index); @@ -1545,8 +1529,6 @@ package body Sem_Ch9 is Call : constant Node_Id := Entry_Call_Statement (N); begin - Tasking_Used := True; - if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; @@ -1589,8 +1571,6 @@ package body Sem_Ch9 is begin Generate_Definition (Def_Id); - Tasking_Used := True; - -- Case of no discrete subtype definition if No (D_Sdef) then @@ -1751,7 +1731,6 @@ package body Sem_Ch9 is Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); begin - Tasking_Used := True; Analyze (Def); -- There is no elaboration of the entry index specification. Therefore, @@ -1848,7 +1827,6 @@ package body Sem_Ch9 is Freeze_Previous_Contracts (N); - Tasking_Used := True; Mutate_Ekind (Body_Id, E_Protected_Body); Set_Etype (Body_Id, Standard_Void_Type); Spec_Id := Find_Concurrent_Spec (Body_Id); @@ -1991,7 +1969,6 @@ package body Sem_Ch9 is -- Start of processing for Analyze_Protected_Definition begin - Tasking_Used := True; Analyze_Declarations (Visible_Declarations (N)); if not Is_Empty_List (Private_Declarations (N)) then @@ -2047,7 +2024,6 @@ package body Sem_Ch9 is return; end if; - Tasking_Used := True; Check_Restriction (No_Protected_Types, N); T := Find_Type_Name (N); @@ -2223,18 +2199,21 @@ package body Sem_Ch9 is -- Pragma case else - if Debug_Flag_Underscore_DD then - Record_Pragma_No_Effect_With_Lock_Free_Warning - (Pragma_Node => Prio_Item, - Pragma_Name => Pragma_Name (Prio_Item), - Lock_Free_Node => Id, - Lock_Free_Range => Parent (Id)); - else - Error_Msg_Name_1 := Pragma_Name (Prio_Item); - Error_Msg_NE - ("pragma% for & has no effect when Lock_Free given??", - Prio_Item, Id); - end if; + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE + (Msg => + "pragma% for & has no effect when Lock_Free given??", + N => Prio_Item, + E => Id, + Error_Code => GNAT0003, + Label => "No effect", + Spans => + (1 => + Labeled_Span + (Span => To_Full_Span (Parent (Id)), + Label => "Lock_Free in effect here", + Is_Primary => False, + Is_Region => True))); end if; end if; end; @@ -2422,7 +2401,6 @@ package body Sem_Ch9 is Modes => True, Warnings => True); - Tasking_Used := True; Check_Restriction (No_Requeue_Statements, N); Check_Unreachable_Code (N); @@ -2754,7 +2732,6 @@ package body Sem_Ch9 is Alt_Count : Uint := Uint_0; begin - Tasking_Used := True; Check_Restriction (No_Select_Statements, N); -- Loop to analyze alternatives @@ -2871,7 +2848,6 @@ package body Sem_Ch9 is begin Generate_Definition (Obj_Id); - Tasking_Used := True; -- A single protected declaration is transformed into a pair of an -- anonymous protected type and an object of that type. Generate: @@ -2959,7 +2935,6 @@ package body Sem_Ch9 is begin Generate_Definition (Obj_Id); - Tasking_Used := True; -- A single task declaration is transformed into a pair of an anonymous -- task type and an object of that type. Generate: @@ -3074,7 +3049,6 @@ package body Sem_Ch9 is Freeze_Previous_Contracts (N); - Tasking_Used := True; Set_Scope (Body_Id, Current_Scope); Mutate_Ekind (Body_Id, E_Task_Body); Set_Etype (Body_Id, Standard_Void_Type); @@ -3219,8 +3193,6 @@ package body Sem_Ch9 is L : Entity_Id; begin - Tasking_Used := True; - if Present (Visible_Declarations (N)) then Analyze_Declarations (Visible_Declarations (N)); end if; @@ -3265,8 +3237,6 @@ package body Sem_Ch9 is -- Proceed ahead with analysis of task type declaration - Tasking_Used := True; - -- The sequential partition elaboration policy is supported only in the -- restricted profile. @@ -3448,8 +3418,6 @@ package body Sem_Ch9 is procedure Analyze_Terminate_Alternative (N : Node_Id) is begin - Tasking_Used := True; - if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; @@ -3469,7 +3437,6 @@ package body Sem_Ch9 is Is_Disp_Select : Boolean := False; begin - Tasking_Used := True; Check_Restriction (No_Select_Statements, N); -- Ada 2005 (AI-345): The trigger may be a dispatching call @@ -3504,8 +3471,6 @@ package body Sem_Ch9 is Trigger : constant Node_Id := Triggering_Statement (N); begin - Tasking_Used := True; - if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 4881d6f..d133676 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -80,7 +80,7 @@ package body Sem_Disp is -- parameter); otherwise returns empty. function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id; - -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching + -- [AI05-0125] Find an inherited hidden primitive of the dispatching -- type of S that has the same name of S, a type-conformant profile, an -- original corresponding operation O that is a primitive of a visible -- ancestor of the dispatching type of S and O is visible at the point of @@ -91,7 +91,8 @@ package body Sem_Disp is -- This routine does not search for non-hidden primitives since they are -- covered by the normal Ada 2005 rules. Its name was motivated by an -- intermediate version of AI05-0125 where this term was proposed to - -- name these entities in the RM. + -- name these entities in the RM. FWIW, note that AI05-0125 was + -- not approved; it was voted "No Action". function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean; -- Check whether a primitive operation is inherited from an operation @@ -1710,9 +1711,8 @@ package body Sem_Disp is Ovr_Subp := Old_Subp; - -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be - -- overridden by Subp. This only applies to source subprograms, and - -- their declaration must carry an explicit overriding indicator. + -- Search for inherited hidden primitive that may be + -- overridden by Subp. This only applies to source subprograms. if No (Ovr_Subp) and then Ada_Version >= Ada_2012 @@ -1721,16 +1721,6 @@ package body Sem_Disp is Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration then Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp); - - -- Warn if the proper overriding indicator has not been supplied. - - if Present (Ovr_Subp) - and then - not Must_Override (Specification (Unit_Declaration_Node (Subp))) - and then not In_Instance - then - Error_Msg_NE ("missing overriding indicator for&??", Subp, Subp); - end if; end if; -- Now it should be a correct primitive operation, put it in the list diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index b7dfe01..fcab3e7 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -144,7 +144,7 @@ package body Sem_Eval is Checking_For_Potentially_Static_Expression : Boolean := False; -- Global flag that is set True during Analyze_Static_Expression_Function -- in order to verify that the result expression of a static expression - -- function is a potentially static function (see RM2022 6.8(5.3)). + -- function is a potentially static function (see RM 2022 6.8(5.3)). ----------------------- -- Local Subprograms -- @@ -574,13 +574,11 @@ package body Sem_Eval is Rewrite (N, New_Copy (N)); - if not Is_Floating_Point_Type (T) then - Set_Realval - (N, Corresponding_Integer_Value (N) * Small_Value (T)); - - elsif not UR_Is_Zero (Realval (N)) then + if Is_Floating_Point_Type (T) then Set_Realval (N, Machine_Number (Base_Type (T), Realval (N), N)); Set_Is_Machine_Number (N); + else + Set_Realval (N, Corresponding_Integer_Value (N) * Small_Value (T)); end if; end if; @@ -4989,27 +4987,41 @@ package body Sem_Eval is end if; end Check_Elab_Call; - Modulus, Val : Uint; - begin - if Compile_Time_Known_Value (Left) - and then Compile_Time_Known_Value (Right) + if not (Compile_Time_Known_Value (Left) + and then Compile_Time_Known_Value (Right)) then - pragma Assert (not Non_Binary_Modulus (Typ)); + return; + end if; + + pragma Assert (not Non_Binary_Modulus (Typ)); + pragma Assert (Expr_Value (Right) >= Uint_0); -- Amount is always Natural + + -- Shift by zero bits is a no-op + + if Expr_Value (Right) = Uint_0 then + Fold_Uint (N, Expr_Value (Left), Static => Static); + return; + end if; + declare + Modulus : constant Uint := + (if Is_Modular_Integer_Type (Typ) then Einfo.Entities.Modulus (Typ) + else Uint_2 ** RM_Size (Typ)); + Amount : constant Uint := UI_Min (Expr_Value (Right), RM_Size (Typ)); + -- Shift by an Amount greater than the size is all-zeros or all-ones. + -- Without this "min", we could use huge amounts of time and memory + -- below (e.g. 2**Amount, if Amount were a billion). + + Val : Uint; + begin if Op = N_Op_Shift_Left then Check_Elab_Call; - if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Entities.Modulus (Typ); - else - Modulus := Uint_2 ** RM_Size (Typ); - end if; - -- Fold Shift_Left (X, Y) by computing -- (X * 2**Y) rem modulus [- Modulus] - Val := (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right))) + Val := (Expr_Value (Left) * (Uint_2 ** Amount)) rem Modulus; if Is_Modular_Integer_Type (Typ) @@ -5023,49 +5035,32 @@ package body Sem_Eval is elsif Op = N_Op_Shift_Right then Check_Elab_Call; - -- X >> 0 is a no-op + -- Fold X >> Y by computing (X [+ Modulus]) / 2**Y. + -- Note that after a Shift_Right operation (with Y > 0), the + -- result is always positive, even if the original operand was + -- negative. - if Expr_Value (Right) = Uint_0 then - Fold_Uint (N, Expr_Value (Left), Static => Static); - else - if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Entities.Modulus (Typ); + declare + M : Unat; + begin + if Expr_Value (Left) >= Uint_0 then + M := Uint_0; else - Modulus := Uint_2 ** RM_Size (Typ); + M := Modulus; end if; - -- Fold X >> Y by computing (X [+ Modulus]) / 2**Y - -- Note that after a Shift_Right operation (with Y > 0), the - -- result is always positive, even if the original operand was - -- negative. - - declare - M : Unat; - begin - if Expr_Value (Left) >= Uint_0 then - M := Uint_0; - else - M := Modulus; - end if; + Fold_Uint + (N, + (Expr_Value (Left) + M) / (Uint_2 ** Amount), + Static => Static); + end; - Fold_Uint - (N, - (Expr_Value (Left) + M) / (Uint_2 ** Expr_Value (Right)), - Static => Static); - end; - end if; elsif Op = N_Op_Shift_Right_Arithmetic then Check_Elab_Call; declare - Two_Y : constant Uint := Uint_2 ** Expr_Value (Right); + Two_Y : constant Uint := Uint_2 ** Amount; begin - if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Entities.Modulus (Typ); - else - Modulus := Uint_2 ** RM_Size (Typ); - end if; - -- X / 2**Y if X if positive or a small enough modular integer if (Is_Modular_Integer_Type (Typ) @@ -5096,7 +5091,7 @@ package body Sem_Eval is (N, (Expr_Value (Left)) / Two_Y + (Two_Y - Uint_1) - * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)), + * Uint_2 ** (RM_Size (Typ) - Amount), Static => Static); -- Negative signed integer, compute via multiple/divide the @@ -5108,13 +5103,15 @@ package body Sem_Eval is (N, (Modulus + Expr_Value (Left)) / Two_Y + (Two_Y - Uint_1) - * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)) + * Uint_2 ** (RM_Size (Typ) - Amount) - Modulus, Static => Static); end if; end; + else + raise Program_Error; end if; - end if; + end; end Fold_Shift; -------------- diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 138278f..b6f44ef 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -301,34 +301,34 @@ package Sem_Eval is -- is static or its value is known at compile time. This version is used -- for string types and returns the corresponding N_String_Literal node. - procedure Eval_Actual (N : Node_Id); - procedure Eval_Allocator (N : Node_Id); - procedure Eval_Arithmetic_Op (N : Node_Id); - procedure Eval_Call (N : Node_Id); - procedure Eval_Case_Expression (N : Node_Id); - procedure Eval_Character_Literal (N : Node_Id); - procedure Eval_Concatenation (N : Node_Id); - procedure Eval_Entity_Name (N : Node_Id); - procedure Eval_If_Expression (N : Node_Id); - procedure Eval_Indexed_Component (N : Node_Id); - procedure Eval_Integer_Literal (N : Node_Id); - procedure Eval_Logical_Op (N : Node_Id); - procedure Eval_Membership_Op (N : Node_Id); - procedure Eval_Named_Integer (N : Node_Id); - procedure Eval_Named_Real (N : Node_Id); - procedure Eval_Op_Expon (N : Node_Id); - procedure Eval_Op_Not (N : Node_Id); - procedure Eval_Real_Literal (N : Node_Id); - procedure Eval_Relational_Op (N : Node_Id); - procedure Eval_Selected_Component (N : Node_Id); - procedure Eval_Shift (N : Node_Id); - procedure Eval_Short_Circuit (N : Node_Id); - procedure Eval_Slice (N : Node_Id); - procedure Eval_String_Literal (N : Node_Id); - procedure Eval_Qualified_Expression (N : Node_Id); - procedure Eval_Type_Conversion (N : Node_Id); - procedure Eval_Unary_Op (N : Node_Id); - procedure Eval_Unchecked_Conversion (N : Node_Id); + procedure Eval_Actual (N : Node_Id); + procedure Eval_Allocator (N : Node_Id); + procedure Eval_Arithmetic_Op (N : Node_Id); + procedure Eval_Call (N : Node_Id); + procedure Eval_Case_Expression (N : Node_Id); + procedure Eval_Character_Literal (N : Node_Id); + procedure Eval_Concatenation (N : Node_Id); + procedure Eval_Entity_Name (N : Node_Id); + procedure Eval_If_Expression (N : Node_Id); + procedure Eval_Indexed_Component (N : Node_Id); + procedure Eval_Integer_Literal (N : Node_Id); + procedure Eval_Logical_Op (N : Node_Id); + procedure Eval_Membership_Op (N : Node_Id); + procedure Eval_Named_Integer (N : Node_Id); + procedure Eval_Named_Real (N : Node_Id); + procedure Eval_Op_Expon (N : Node_Id); + procedure Eval_Op_Not (N : Node_Id); + procedure Eval_Real_Literal (N : Node_Id); + procedure Eval_Relational_Op (N : Node_Id); + procedure Eval_Selected_Component (N : Node_Id); + procedure Eval_Shift (N : Node_Id); + procedure Eval_Short_Circuit (N : Node_Id); + procedure Eval_Slice (N : Node_Id); + procedure Eval_String_Literal (N : Node_Id); + procedure Eval_Qualified_Expression (N : Node_Id); + procedure Eval_Type_Conversion (N : Node_Id); + procedure Eval_Unary_Op (N : Node_Id); + procedure Eval_Unchecked_Conversion (N : Node_Id); procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id); -- This procedure is called after it has been determined that Expr is not @@ -342,41 +342,12 @@ package Sem_Eval is -- set of messages is all posted. procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean); - -- Rewrite N with a new N_String_Literal node as the result of the compile - -- time evaluation of the node N. Val is the resulting string value from - -- the folding operation. The Is_Static_Expression flag is set in the - -- result node. The result is fully analyzed and resolved. Static indicates - -- whether the result should be considered static or not (True = consider - -- static). The point here is that normally all string literals are static, - -- but if this was the result of some sequence of evaluation where values - -- were known at compile time but not static, then the result is not - -- static. The call has no effect if Raises_Constraint_Error (N) is True, - -- since there is no point in folding if we have an error. - procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean); - -- Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal) - -- node as the result of the compile time evaluation of the node N. Val is - -- the result in the integer case and is the position of the literal in the - -- literals list for the enumeration case. Is_Static_Expression is set True - -- in the result node. The result is fully analyzed/resolved. Static - -- indicates whether the result should be considered static or not (True = - -- consider static). The point here is that normally all integer literals - -- are static, but if this was the result of some sequence of evaluation - -- where values were known at compile time but not static, then the result - -- is not static. The call has no effect if Raises_Constraint_Error (N) is - -- True, since there is no point in folding if we have an error. - procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean); - -- Rewrite N with a new N_Real_Literal node as the result of the compile - -- time evaluation of the node N. Val is the resulting real value from the - -- folding operation. The Is_Static_Expression flag is set in the result - -- node. The result is fully analyzed and result. Static indicates whether - -- the result should be considered static or not (True = consider static). - -- The point here is that normally all string literals are static, but if - -- this was the result of some sequence of evaluation where values were - -- known at compile time but not static, then the result is not static. - -- The call has no effect if Raises_Constraint_Error (N) is True, since - -- there is no point in folding if we have an error. + -- Rewrite N with a new literal node with compile-time-known value Val. + -- Is_Static_Expression is set to Static. This has no effect if + -- Raises_Constraint_Error (N) is True, since there is no point in + -- folding if we have an error. procedure Fold (N : Node_Id); -- Rewrite N with the relevant value if Compile_Time_Known_Value (N) is diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 621edc7..4090d0c 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -216,10 +216,10 @@ package body Sem_Prag is (Prag : Node_Id; Spec_Id : Entity_Id); -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition, - -- Precondition, Refined_Post, Subprogram_Variant, and Test_Case. Emit a - -- warning when pragma Prag is associated with subprogram Spec_Id subject - -- to Inline_Always, assertions are enabled and inling is done in the - -- frontend. + -- Precondition, Program_Exit, Refined_Post, Subprogram_Variant, and + -- Test_Case. Emit a warning when pragma Prag is associated with subprogram + -- Spec_Id subject to Inline_Always, assertions are enabled and inling is + -- done in the frontend. procedure Check_State_And_Constituent_Use (States : Elist_Id; @@ -234,9 +234,10 @@ package body Sem_Prag is (Contract_Id : Entity_Id; Freeze_Id : Entity_Id); -- Subsidiary to the analysis of pragmas Contract_Cases, Exceptional_Cases, - -- Part_Of, Post, Pre and Subprogram_Variant. Emit a freezing-related error - -- message where Freeze_Id is the entity of a body which caused contract - -- freezing and Contract_Id denotes the entity of the affected contstruct. + -- Part_Of, Post, Pre, Program_Exit and Subprogram_Variant. Emit a + -- freezing-related error message where Freeze_Id is the entity of a body + -- which caused contract freezing and Contract_Id denotes the entity of the + -- affected contstruct. procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id); -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma @@ -474,7 +475,8 @@ package body Sem_Prag is end if; Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Expression (Arg1), Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Expression (Arg1), Standard_Boolean); -- Emit a clarification message when the expression contains at least -- one undefined reference, possibly due to contract freezing. @@ -564,7 +566,8 @@ package body Sem_Prag is if Nkind (Case_Guard) /= N_Others_Choice then Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Case_Guard, Standard_Boolean); -- Emit a clarification message when the case guard contains -- at least one undefined reference, possibly due to contract @@ -579,7 +582,8 @@ package body Sem_Prag is end if; Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Conseq, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Conseq, Standard_Boolean); -- Emit a clarification message when the consequence contains -- at least one undefined reference, possibly due to contract @@ -2391,9 +2395,10 @@ package body Sem_Prag is Errors := Serious_Errors_Detected; - -- Preanalyze_Assert_Expression enforcing the expression type + -- Preanalyze_And_Resolve_Assert_Expression enforcing the expression + -- type. - Preanalyze_Assert_Expression (Consequence, Any_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Consequence, Any_Boolean); Check_Params (Consequence); @@ -2621,7 +2626,8 @@ package body Sem_Prag is if Nkind (Case_Guard) /= N_Others_Choice then Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Case_Guard, Standard_Boolean); -- Emit a clarification message when the case guard contains -- at least one undefined reference, possibly due to contract @@ -2636,14 +2642,16 @@ package body Sem_Prag is end if; -- Check the exit kind. It shall be either an exception or the - -- identifiers Normal_Return or Any_Exception. + -- identifiers Normal_Return, Exception_Raised, or Program_Exit. if Nkind (Exit_Kind) = N_Identifier then if Chars (Exit_Kind) not in Name_Normal_Return | Name_Exception_Raised + | Name_Program_Exit then Error_Msg_N - ("exit kind should be Normal_Return or Exception_Raised", + ("exit kind should be Normal_Return, Exception_Raised, " & + "or Program_Exit", Exit_Kind); end if; @@ -5112,10 +5120,6 @@ package body Sem_Prag is -- Determines if the placement of the current pragma is appropriate -- for a configuration pragma. - function Is_In_Context_Clause return Boolean; - -- Returns True if pragma appears within the context clause of a unit, - -- and False for any other placement (does not generate any messages). - function Is_Static_String_Expression (Arg : Node_Id) return Boolean; -- Analyzes the argument, and determines if it is a static string -- expression, returns True if so, False if non-static or not String. @@ -5585,7 +5589,7 @@ package body Sem_Prag is if Present (Arg2) then Check_Optional_Identifier (Arg2, Name_Message); - Preanalyze_Assert_Expression + Preanalyze_And_Resolve_Assert_Expression (Get_Pragma_Arg (Arg2), Standard_String); end if; end if; @@ -6009,7 +6013,7 @@ package body Sem_Prag is -- Check case of appearing within context clause - if not Is_Unused and then Is_In_Context_Clause then + if not Is_Unused and then Is_In_Context_Clause (N) then -- The arguments must all be units mentioned in a with clause in -- the same context clause. Note that Par.Prag already checked @@ -8127,27 +8131,6 @@ package body Sem_Prag is end if; end Is_Configuration_Pragma; - -------------------------- - -- Is_In_Context_Clause -- - -------------------------- - - function Is_In_Context_Clause return Boolean is - Plist : List_Id; - Parent_Node : Node_Id; - - begin - if Is_List_Member (N) then - Plist := List_Containing (N); - Parent_Node := Parent (Plist); - - return Present (Parent_Node) - and then Nkind (Parent_Node) = N_Compilation_Unit - and then Context_Items (Parent_Node) = Plist; - end if; - - return False; - end Is_In_Context_Clause; - --------------------------------- -- Is_Static_String_Expression -- --------------------------------- @@ -10049,7 +10032,6 @@ package body Sem_Prag is end if; Def_Id := Entity (Def_Id); - Kill_Size_Check_Code (Def_Id); if Ekind (Def_Id) /= E_Constant then Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False); @@ -10062,7 +10044,6 @@ package body Sem_Prag is -- purposes of legality checks and removal of ignored Ghost code. Mark_Ghost_Pragma (N, Def_Id); - Kill_Size_Check_Code (Def_Id); if Ekind (Def_Id) /= E_Constant then Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); @@ -14065,7 +14046,7 @@ package body Sem_Prag is -- Perform preanalysis to deal with embedded Loop_Entry -- attributes. - Preanalyze_Assert_Expression (Expr, Any_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean); end if; -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating @@ -16166,7 +16147,8 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); + Preanalyze_And_Resolve_Spec_Expression + (Arg, RTE (RE_CPU_Range)); -- See comment in Sem_Ch13 about the following restrictions @@ -16212,7 +16194,7 @@ package body Sem_Prag is -- The expression must be analyzed in the special manner described -- in "Handling of Default and Per-Object Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); + Preanalyze_And_Resolve_Spec_Expression (Arg, RTE (RE_Time_Span)); -- Only protected types allowed @@ -16841,7 +16823,8 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); + Preanalyze_And_Resolve_Spec_Expression + (Arg, RTE (RE_Dispatching_Domain)); -- Check duplicate pragma before we chain the pragma in the Rep -- Item chain of Ent. @@ -16869,7 +16852,7 @@ package body Sem_Prag is begin -- Pragma must be in context items list of a compilation unit - if not Is_In_Context_Clause then + if not Is_In_Context_Clause (N) then Pragma_Misplaced; end if; @@ -16965,7 +16948,7 @@ package body Sem_Prag is -- Pragma must be in context items list of a compilation unit - if not Is_In_Context_Clause then + if not Is_In_Context_Clause (N) then Pragma_Misplaced; end if; @@ -17457,6 +17440,7 @@ package body Sem_Prag is -- -- EXIT_KIND ::= -- Normal_Return + -- | Program_Exit -- | Exception_Raised -- | (Exception_Raised => exception_name) -- @@ -19964,7 +19948,6 @@ package body Sem_Prag is -- object to be imported. if Ekind (Def_Id) = E_Variable then - Kill_Size_Check_Code (Def_Id); Note_Possible_Modification (Id, Sure => False); -- Initialization is not allowed for imported variable @@ -20074,7 +20057,8 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); + Preanalyze_And_Resolve_Spec_Expression + (Arg, RTE (RE_Interrupt_Priority)); end if; if Nkind (P) not in N_Task_Definition | N_Protected_Definition then @@ -20979,10 +20963,10 @@ package body Sem_Prag is ("Structural variant shall be the only variant", Variant); end if; - -- Preanalyze_Assert_Expression, but without enforcing any of - -- the two acceptable types. + -- Preanalyze_And_Resolve_Assert_Expression, but without + -- enforcing any of the two acceptable types. - Preanalyze_Assert_Expression (Expression (Variant)); + Preanalyze_And_Resolve_Assert_Expression (Expression (Variant)); -- Expression of a discrete type is allowed. Nothing to -- check for structural variants. @@ -20992,7 +20976,7 @@ package body Sem_Prag is then null; - -- Expression of a Big_Integer type (or its ghost variant) is + -- Expression of a Big_Integer type (or its SPARK variant) is -- only allowed in Decreases clause. elsif @@ -21000,9 +20984,6 @@ package body Sem_Prag is RE_Big_Integer) or else Is_RTE (Base_Type (Etype (Expression (Variant))), - RO_GH_Big_Integer) - or else - Is_RTE (Base_Type (Etype (Expression (Variant))), RO_SP_Big_Integer) then if Chars (Variant) = Name_Increases then @@ -23410,7 +23391,8 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority)); + Preanalyze_And_Resolve_Spec_Expression + (Arg, RTE (RE_Any_Priority)); if not Is_OK_Static_Expression (Arg) then Check_Restriction (Static_Priorities, Arg); @@ -23615,6 +23597,132 @@ package body Sem_Prag is end if; end; + ------------------ + -- Program_Exit -- + ------------------ + + -- pragma Program_Exit (Boolean_EXPRESSION); + + -- Characteristics: + + -- * Analysis - The annotation undergoes initial checks to verify + -- the legal placement and context. Secondary checks preanalyze the + -- expression in: + + -- Analyze_Program_Exit_In_Decl_Part + + -- * Expansion - The annotation is expanded during the expansion of + -- the related subprogram [body] contract as performed in: + + -- Expand_Subprogram_Contract + + -- * Template - The annotation utilizes the generic template of the + -- related subprogram [body] when it is: + + -- aspect on subprogram declaration + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body + + -- The annotation must prepare its own template when it is: + + -- pragma on subprogram declaration + + -- * Globals - Capture of global references must occur after full + -- analysis. + + -- * Instance - The annotation is instantiated automatically when + -- the related generic subprogram [body] is instantiated except for + -- the "pragma on subprogram declaration" case. In that scenario + -- the annotation must instantiate itself. + + when Pragma_Program_Exit => Program_Exit : declare + Spec_Id : Entity_Id; + Subp_Decl : Node_Id; + Subp_Spec : Node_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_At_Most_N_Arguments (1); + + -- Ensure the proper placement of the pragma. Program_Exit must be + -- associated with a subprogram declaration or a body that acts as + -- a spec. + + Subp_Decl := + Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Generic subprogram + + if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then + null; + + -- Body acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Subp_Decl)) + then + null; + + -- Body stub acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) + then + null; + + -- Subprogram + + elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then + Subp_Spec := Specification (Subp_Decl); + + -- Pragma Program_Exit is forbidden on null procedures, as this + -- may lead to potential ambiguities in behavior when interface + -- null procedures are involved. Also, it just wouldn't make + -- sense, because null procedure always exits. + + if Nkind (Subp_Spec) = N_Procedure_Specification + and then Null_Present (Subp_Spec) + then + Error_Msg_N (Fix_Error + ("pragma % cannot apply to null procedure"), N); + return; + end if; + + else + Pragma_Misplaced; + end if; + + Spec_Id := Unique_Defining_Entity (Subp_Decl); + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Ghost_Pragma (N, Spec_Id); + + -- Chain the pragma on the contract for further processing by + -- Analyze_Program_Exit. + + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); + + -- Fully analyze the pragma when it appears inside a subprogram + -- body because it cannot benefit from forward references. + + if Nkind (Subp_Decl) in N_Subprogram_Body + | N_Subprogram_Body_Stub + then + -- The legality checks of pragma Program_Exit are affected by + -- the SPARK mode in effect and the volatility of the context. + -- Analyze all pragmas in a specific order. + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); + Analyze_If_Present (Pragma_Global); + Analyze_If_Present (Pragma_Depends); + Analyze_Program_Exit_In_Decl_Part (N); + end if; + end Program_Exit; + ---------------------- -- Profile_Warnings -- ---------------------- @@ -23982,7 +24090,7 @@ package body Sem_Prag is Analyze_If_Present (Pragma_Side_Effects); -- A function with side effects shall not have a Pure_Function - -- aspect or pragma (SPARK RM 6.1.11(5)). + -- aspect or pragma (SPARK RM 6.1.12(5)). if Is_Function_With_Side_Effects (E) then Error_Pragma @@ -24397,7 +24505,7 @@ package body Sem_Prag is -- The expression must be analyzed in the special manner described -- in "Handling of Default and Per-Object Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); + Preanalyze_And_Resolve_Spec_Expression (Arg, RTE (RE_Time_Span)); -- Subprogram case @@ -24657,7 +24765,7 @@ package body Sem_Prag is -- The expression must be analyzed in the special manner -- described in "Handling of Default Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, Any_Integer); + Preanalyze_And_Resolve_Spec_Expression (Arg, Any_Integer); -- The pragma cannot appear if the No_Secondary_Stack -- restriction is in effect. @@ -25815,7 +25923,7 @@ package body Sem_Prag is -- in "Handling of Default Expressions" in sem.ads. Arg := Get_Pragma_Arg (Arg1); - Preanalyze_Spec_Expression (Arg, Any_Integer); + Preanalyze_And_Resolve_Spec_Expression (Arg, Any_Integer); if not Is_OK_Static_Expression (Arg) then Check_Restriction (Static_Storage_Size, Arg); @@ -26845,7 +26953,7 @@ package body Sem_Prag is Opt.Time_Slice_Set := True; Val := Expr_Value_R (Get_Pragma_Arg (Arg1)); - if Val <= Ureal_0 then + if not UR_Is_Positive (Val) then Opt.Time_Slice_Value := 0; elsif Val > UR_From_Uint (UI_From_Int (1000)) then @@ -28241,7 +28349,7 @@ package body Sem_Prag is end if; Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Expr, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Expr, Standard_Boolean); -- Emit a clarification message when the expression contains at least -- one undefined reference, possibly due to contract freezing. @@ -28296,6 +28404,153 @@ package body Sem_Prag is Restore_Ghost_Region (Saved_GM, Saved_IGR); end Analyze_Pre_Post_Condition_In_Decl_Part; + --------------------------------------- + -- Analyze_Program_Exit_In_Decl_Part -- + --------------------------------------- + + -- WARNING: This routine manages Ghost regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- Ghost mode. + + procedure Analyze_Program_Exit_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty) + is + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (N)); + + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + -- Save the Ghost-related attributes to restore on exit + + Errors : Nat; + Restore_Scope : Boolean := False; + Unused : Boolean; + + Subp_Inputs, Subp_Outputs : Elist_Id := No_Elist; + -- Inputs and outputs of the subprogram + + function Check_Reference (N : Node_Id) return Traverse_Result; + -- Check references to objects within the Program_Exit expression + + --------------------- + -- Check_Reference -- + --------------------- + + function Check_Reference (N : Node_Id) return Traverse_Result is + begin + -- If an output of a subprogram with side effects is mentioned + -- in the boolean expression of its aspect Program_Exit, then it + -- shall either occur inside the prefix of a reference to the Old + -- attribute or be a stand-alone object. + + if Is_Attribute_Old (N) then + return Skip; + end if; + + if Is_Entity_Name (N) then + declare + E : constant Entity_Id := Entity (N); + begin + if Appears_In (Subp_Outputs, E) + and then Ekind (E) not in E_Constant | E_Variable + then + Error_Msg_NE + ("reference to subprogram output & in Program_Exit", N, E); + end if; + end; + end if; + + return OK; + end Check_Reference; + + procedure Check_Exit_References is new Traverse_Proc (Check_Reference); + + -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part + + begin + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + + if Ekind (Spec_Id) in E_Function | E_Generic_Function + and then not Is_Function_With_Side_Effects (Spec_Id) + then + Error_Msg_N + ("aspect Program_Exit is only allowed " & + "for subprograms with side effects", N); + end if; + + if Present (Arg1) then + + -- Set the Ghost mode in effect from the pragma. Due to the delayed + -- analysis of the pragma, the Ghost mode at point of declaration and + -- point of analysis may not necessarily be the same. Use the mode in + -- effect at the point of declaration. + + Set_Ghost_Mode (N); + + -- Ensure that the subprogram and its formals are visible when + -- analyzing the expression of the pragma. + + if not In_Open_Scopes (Spec_Id) then + Restore_Scope := True; + + if Is_Generic_Subprogram (Spec_Id) then + Push_Scope (Spec_Id); + Install_Generic_Formals (Spec_Id); + else + Push_Scope (Spec_Id); + Install_Formals (Spec_Id); + end if; + end if; + + Errors := Serious_Errors_Detected; + + -- Preanalyze_And_Resolve_Assert_Expression enforcing the expression + -- type. + + Preanalyze_And_Resolve_Assert_Expression + (Expression (Arg1), Any_Boolean); + + Collect_Subprogram_Inputs_Outputs + (Spec_Id, + Synthesize => True, + Subp_Inputs => Subp_Inputs, + Subp_Outputs => Subp_Outputs, + Global_Seen => Unused); + + Check_Exit_References (Expression (Arg1)); + + -- Emit a clarification message when the expression contains at least + -- one undefined reference, possibly due to contract freezing. + + if Errors /= Serious_Errors_Detected + and then Present (Freeze_Id) + and then Has_Undefined_Reference (Expression (Arg1)) + then + Contract_Freeze_Error (Spec_Id, Freeze_Id); + end if; + + if Restore_Scope then + End_Scope; + end if; + + -- Currently it is not possible to inline pre/postconditions on a + -- subprogram subject to pragma Inline_Always. + + Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); + + Restore_Ghost_Region (Saved_GM, Saved_IGR); + end if; + + Set_Is_Analyzed_Pragma (N); + end Analyze_Program_Exit_In_Decl_Part; + ------------------------------------------ -- Analyze_Refined_Depends_In_Decl_Part -- ------------------------------------------ @@ -30956,34 +31211,67 @@ package body Sem_Prag is -- end Pack; if Constit_Id = Any_Id then - SPARK_Msg_NE ("& is undefined", Constit, Constit_Id); + -- A "Foo is undefined" message has already been + -- generated for this constituent. Emit an additional + -- message in the special case where the named + -- would-be constituent was declared too late in the + -- declaration list (as opposed to, for example, not + -- being declared at all). + + -- Look for named constituent after freezing point + if Present (Freeze_Id) then + declare + Decl : Node_Id; + begin + Decl := Enclosing_Declaration (Freeze_Id); - -- Emit a specialized info message when the contract of - -- the related package body was "frozen" by another body. - -- Note that it is not possible to precisely identify why - -- the constituent is undefined because it is not visible - -- when pragma Refined_State is analyzed. This message is - -- a reasonable approximation. + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration + and then Same_Name (Defining_Identifier (Decl), + Constit) + and then not Constant_Present (Decl) + then + Error_Msg_Node_1 := Constit; + Error_Msg_Sloc := + Sloc (Defining_Identifier (Decl)); - if Present (Freeze_Id) and then not Freeze_Posted then - Freeze_Posted := True; + SPARK_Msg_NE + ("abstract state constituent & declared" + & " too late #!", Constit, Constit); - Error_Msg_Name_1 := Chars (Body_Id); - Error_Msg_Sloc := Sloc (Freeze_Id); - SPARK_Msg_NE - ("body & declared # freezes the contract of %", - N, Freeze_Id); - SPARK_Msg_N - ("\all constituents must be declared before body #", - N); + exit; + end if; + Next (Decl); + end loop; + end; + + -- Emit a specialized info message when the contract + -- of the related package body was "frozen" by + -- another body. If a "declared too late" message + -- is generated, this will clarify what is meant by + -- "too late". + + if not Freeze_Posted then + Freeze_Posted := True; - -- A misplaced constituent is a critical error because - -- pragma Refined_Depends or Refined_Global depends on - -- the proper link between a state and a constituent. - -- Stop the compilation, as this leads to a multitude - -- of misleading cascaded errors. + Error_Msg_Name_1 := Chars (Body_Id); + Error_Msg_Sloc := Sloc (Freeze_Id); + SPARK_Msg_NE + ("body & declared # freezes the contract of %", + N, Freeze_Id); + SPARK_Msg_N + ("\all constituents must be declared" & + " before body #", N); - raise Unrecoverable_Error; + -- A misplaced constituent is a critical error + -- because pragma Refined_Depends or + -- Refined_Global depends on the proper link + -- between a state and a constituent. Stop the + -- compilation, as this leads to a multitude of + -- misleading cascaded errors. + + raise Unrecoverable_Error; + end if; end if; -- The constituent is a valid state or object @@ -31452,10 +31740,10 @@ package body Sem_Prag is Errors := Serious_Errors_Detected; - -- Preanalyze_Assert_Expression, but without enforcing any of the - -- acceptable types. + -- Preanalyze_And_Resolve_Assert_Expression, but without enforcing + -- any of the acceptable types. - Preanalyze_Assert_Expression (Expr); + Preanalyze_And_Resolve_Assert_Expression (Expr); -- Expression of a discrete type is allowed. Nothing more to check -- for structural variants. @@ -31468,12 +31756,8 @@ package body Sem_Prag is -- Expression of a Big_Integer type (or its ghost variant) is only -- allowed in Decreases clause. - elsif - Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer) - or else - Is_RTE (Base_Type (Etype (Expr)), RO_GH_Big_Integer) - or else - Is_RTE (Base_Type (Etype (Expr)), RO_SP_Big_Integer) + elsif Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer) + or else Is_RTE (Base_Type (Etype (Expr)), RO_SP_Big_Integer) then if Chars (Direction) = Name_Increases then Error_Msg_N @@ -31633,7 +31917,7 @@ package body Sem_Prag is From_Aspect => True); if Present (Arg) then - Preanalyze_Assert_Expression + Preanalyze_And_Resolve_Assert_Expression (Expression (Arg), Standard_Boolean); end if; end if; @@ -31641,7 +31925,8 @@ package body Sem_Prag is Arg := Test_Case_Arg (N, Arg_Nam); if Present (Arg) then - Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Expression (Arg), Standard_Boolean); end if; end Preanalyze_Test_Case_Arg; @@ -33640,6 +33925,7 @@ package body Sem_Prag is Pragma_Profile => 0, Pragma_Profile_Warnings => 0, Pragma_Propagate_Exceptions => 0, + Pragma_Program_Exit => -1, Pragma_Provide_Shift_Operators => 0, Pragma_Psect_Object => 0, Pragma_Pure => 0, diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 7c19d85..9228a87 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -97,6 +97,7 @@ package Sem_Prag is Pragma_Preelaborable_Initialization => True, Pragma_Preelaborate => True, Pragma_Priority => True, + Pragma_Program_Exit => True, Pragma_Pure => True, Pragma_Pure_Function => True, Pragma_Refined_Depends => True, @@ -156,6 +157,7 @@ package Sem_Prag is Pragma_Pre_Class => True, Pragma_Precondition => True, Pragma_Predicate => True, + Pragma_Program_Exit => True, Pragma_Refined_Post => True, Pragma_Subprogram_Variant => True, Pragma_Test_Case => True, @@ -229,6 +231,7 @@ package Sem_Prag is Pragma_Pre => True, Pragma_Pre_Class => True, Pragma_Precondition => True, + Pragma_Program_Exit => True, Pragma_Pure => True, Pragma_Pure_Function => True, Pragma_Refined_Depends => True, @@ -326,6 +329,13 @@ package Sem_Prag is -- subprogram body which caused "freezing" of the related contract where -- the pragma resides. + procedure Analyze_Program_Exit_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty); + -- Perform full analysis of delayed pragma Program_Exit. Freeze_Id is the + -- entity of [generic] package body or [generic] subprogram body which + -- caused "freezing" of the related contract where the pragma resides. + procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id); -- Preform full analysis of delayed pragma Refined_Depends. This routine -- uses Analyze_Depends_In_Decl_Part as a starting point, then performs @@ -494,6 +504,7 @@ package Sem_Prag is -- Pre -- Pre_Class -- Precondition + -- Program_Exit -- Refined_Depends -- Refined_Global -- Refined_Post diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b73b947..96e8da6 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -757,14 +757,6 @@ package body Sem_Res is goto No_Danger; end if; - -- If the enclosing type is limited, we allocate only the - -- default value, not the maximum, and there is no need for - -- a warning. - - if Is_Limited_Type (Scope (Disc)) then - goto No_Danger; - end if; - -- Check that it is the high bound if N /= High_Bound (PN) @@ -811,11 +803,9 @@ package body Sem_Res is goto No_Danger; end if; - -- Warn about the danger - - Error_Msg_N - ("??creation of & object may raise Storage_Error!", - Scope (Disc)); + if Ekind (Scope (Disc)) = E_Record_Type then + Set_Is_Large_Unconstrained_Definite (Scope (Disc)); + end if; <<No_Danger>> null; @@ -2106,8 +2096,6 @@ package body Sem_Res is Full_Analysis := False; Expander_Mode_Save_And_Set (False); - -- See also Preanalyze_And_Resolve in sem.adb for similar handling - -- Normally, we suppress all checks for this preanalysis. There is no -- point in processing them now, since they will be applied properly -- and in the proper location when the default expressions reanalyzed @@ -2150,8 +2138,13 @@ package body Sem_Res is Full_Analysis := False; Expander_Mode_Save_And_Set (False); - Analyze (N); - Resolve (N, Etype (N), Suppress => All_Checks); + -- See previous version of Preanalyze_And_Resolve for similar handling + + if GNATprove_Mode then + Analyze_And_Resolve (N); + else + Analyze_And_Resolve (N, Suppress => All_Checks); + end if; Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; @@ -4849,6 +4842,7 @@ package body Sem_Res is if not Is_OK_Variable_For_Out_Formal (A) and then not Is_Init_Proc (Nam) + and then not Is_Expanded_Constructor_Call (N) then Error_Msg_NE ("actual for& must be a variable", A, F); @@ -6101,6 +6095,8 @@ package body Sem_Res is elsif Is_Fixed_Point_Type (It.Typ) then if Analyzed (N) then Error_Msg_N ("ambiguous operand in fixed operation", N); + elsif It.Typ = Any_Fixed then + Resolve (N, B_Typ); else Resolve (N, It.Typ); end if; @@ -7801,6 +7797,7 @@ package body Sem_Res is then Set_Entity (N, Local); Set_Etype (N, Etype (Local)); + Generate_Reference (Local, N); end if; return OK; @@ -8150,6 +8147,7 @@ package body Sem_Res is and then not Preanalysis_Active and then not Is_Imported (E) and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration + and then not Needs_Construction (Etype (E)) then if No_Initialization (Parent (E)) or else (Present (Full_View (E)) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0e1505b..0ce9e95 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3025,7 +3025,7 @@ package body Sem_Util is -- For an array aggregate, a discrete_choice_list that has -- a nonstatic range is considered as two or more separate - -- occurrences of the expression (RM 6.4.1(20/3)). + -- occurrences of the expression (RM 6.4.1(6.20/3)). elsif Is_Array_Type (Etype (N)) and then Nkind (N) = N_Aggregate @@ -3110,48 +3110,105 @@ package body Sem_Util is end loop; end if; - -- Handle discrete associations + -- Handle named associations if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop - if not Box_Present (Assoc) then - Choice := First (Choices (Assoc)); - while Present (Choice) loop + Handle_Association : declare - -- For now we skip discriminants since it requires - -- performing the analysis in two phases: first one - -- analyzing discriminants and second one analyzing - -- the rest of components since discriminants are - -- evaluated prior to components: too much extra - -- work to detect a corner case??? + procedure Collect_Expression_Ids (Expr : Node_Id); + -- Collect identifiers in association expression Expr - if Nkind (Choice) in N_Has_Entity - and then Present (Entity (Choice)) - and then Ekind (Entity (Choice)) = E_Discriminant - then - null; + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id); + -- Collect identifiers in an association expression + -- Expr for each choice in Choices. - elsif Box_Present (Assoc) then - null; + ---------------------------- + -- Collect_Expression_Ids -- + ---------------------------- + procedure Collect_Expression_Ids (Expr : Node_Id) is + Comp_Expr : Node_Id; + + begin + if not Analyzed (Expr) then + Comp_Expr := New_Copy_Tree (Expr); + Set_Parent (Comp_Expr, Parent (N)); + Preanalyze_Without_Errors (Comp_Expr); else - if not Analyzed (Expression (Assoc)) then - Comp_Expr := - New_Copy_Tree (Expression (Assoc)); - Set_Parent (Comp_Expr, Parent (N)); - Preanalyze_Without_Errors (Comp_Expr); + Comp_Expr := Expr; + end if; + + Collect_Identifiers (Comp_Expr); + end Collect_Expression_Ids; + + -------------------------------- + -- Handle_Association_Choices -- + -------------------------------- + + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id) + is + Choice : Node_Id := First (Choices); + + begin + while Present (Choice) loop + + -- For now skip discriminants since it requires + -- performing analysis in two phases: first one + -- analyzing discriminants and second analyzing + -- the rest of components since discriminants + -- are evaluated prior to components: too much + -- extra work to detect a corner case??? + + if Nkind (Choice) in N_Has_Entity + and then Present (Entity (Choice)) + and then + Ekind (Entity (Choice)) = E_Discriminant + then + null; + else - Comp_Expr := Expression (Assoc); + Collect_Expression_Ids (Expr); end if; - Collect_Identifiers (Comp_Expr); - end if; + Next (Choice); + end loop; + end Handle_Association_Choices; - Next (Choice); - end loop; - end if; + begin + if not Box_Present (Assoc) then + if Nkind (Assoc) = N_Component_Association then + Handle_Association_Choices + (Choices (Assoc), Expression (Assoc)); + + elsif + Nkind (Assoc) = N_Iterated_Component_Association + and then Present (Defining_Identifier (Assoc)) + then + Handle_Association_Choices + (Discrete_Choices (Assoc), Expression (Assoc)); + + -- Nkind (Assoc) = N_Iterated_Component_Association + -- with iterator_specification, or + -- Nkind (Assoc) = N_Iterated_Element_Association + -- with loop_parameter_specification + -- or iterator_specification + -- + -- It seems that we might also need to deal with + -- iterable/iterator_names and iterator_filters + -- within iterator_specifications, and range bounds + -- within loop_parameter_specifications, but the + -- utility of doing that seems very low. ??? + + else + Collect_Expression_Ids (Expression (Assoc)); + end if; + end if; + end Handle_Association; Next (Assoc); end loop; @@ -5619,10 +5676,8 @@ package body Sem_Util is -- to start scanning from the incomplete view, which is earlier on -- the entity chain. - elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration - and then Present (Incomplete_View (Parent (B_Type))) - then - Id := Incomplete_View (Parent (B_Type)); + elsif Present (Incomplete_View (B_Type)) then + Id := Incomplete_View (B_Type); -- If T is a derived from a type with an incomplete view declared -- elsewhere, that incomplete view is irrelevant, we want the @@ -5662,6 +5717,7 @@ package body Sem_Util is or else Is_Primitive (Id)) and then Parent_Kind (Parent (Id)) not in N_Formal_Subprogram_Declaration + and then not Is_Child_Unit (Id) then Is_Prim := False; @@ -6578,6 +6634,30 @@ package body Sem_Util is return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ); end CW_Or_Needs_Finalization; + ------------------------- + -- Default_Constructor -- + ------------------------- + + function Default_Constructor (Typ : Entity_Id) return Entity_Id is + Construct : Elmt_Id; + begin + pragma Assert (Is_Type (Typ)); + if No (Constructor_Name (Typ)) or else No (Constructor_List (Typ)) then + return Empty; + end if; + + Construct := First_Elmt (Constructor_List (Typ)); + while Present (Construct) loop + if Parameter_Count (Elists.Node (Construct)) = 1 then + return Elists.Node (Construct); + end if; + + Next_Elmt (Construct); + end loop; + + return Empty; + end Default_Constructor; + --------------------- -- Defining_Entity -- --------------------- @@ -8063,12 +8143,20 @@ package body Sem_Util is loop Ren := Renamed_Object (Id); + -- The reference renames a function result. Check the original + -- node in case expansion relocates the function call. + + -- Ren : ... renames Func_Call; + + if Nkind (Original_Node (Ren)) = N_Function_Call then + exit; + -- The reference renames an abstract state or a whole object -- Obj : ...; -- Ren : ... renames Obj; - if Is_Entity_Name (Ren) then + elsif Is_Entity_Name (Ren) then -- Do not follow a renaming that goes through a generic formal, -- because these entities are hidden and must not be referenced @@ -8081,14 +8169,6 @@ package body Sem_Util is Id := Entity (Ren); end if; - -- The reference renames a function result. Check the original - -- node in case expansion relocates the function call. - - -- Ren : ... renames Func_Call; - - elsif Nkind (Original_Node (Ren)) = N_Function_Call then - exit; - -- Otherwise the reference renames something which does not yield -- an abstract state or a whole object. Treat the reference as not -- having a proper entity for SPARK legality purposes. @@ -12368,9 +12448,14 @@ package body Sem_Util is while Present (Node) loop case Nkind (Node) is - when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => + when N_Null_Statement | N_Call_Marker => null; + when N_Raise_xxx_Error => + if Comes_From_Source (Node) then + return False; + end if; + when N_Object_Declaration => if Present (Expression (Node)) and then not Side_Effect_Free (Expression (Node)) @@ -17815,6 +17900,27 @@ package body Sem_Util is return Nkind (Spec_Decl) in N_Generic_Declaration; end Is_Generic_Declaration_Or_Body; + -------------------------- + -- Is_In_Context_Clause -- + -------------------------- + + function Is_In_Context_Clause (N : Node_Id) return Boolean is + Plist : List_Id; + Parent_Node : Node_Id; + + begin + if Is_List_Member (N) then + Plist := List_Containing (N); + Parent_Node := Parent (Plist); + + return Present (Parent_Node) + and then Nkind (Parent_Node) = N_Compilation_Unit + and then Context_Items (Parent_Node) = Plist; + end if; + + return False; + end Is_In_Context_Clause; + --------------------------- -- Is_Independent_Object -- --------------------------- @@ -20863,6 +20969,7 @@ package body Sem_Util is or else Nam = Name_Pre or else Nam = Name_Pre_Class or else Nam = Name_Precondition + or else Nam = Name_Program_Exit or else Nam = Name_Refined_Depends or else Nam = Name_Refined_Global or else Nam = Name_Refined_Post @@ -21876,20 +21983,6 @@ package body Sem_Util is end loop Scope_Loop; end Kill_Current_Values; - -------------------------- - -- Kill_Size_Check_Code -- - -------------------------- - - procedure Kill_Size_Check_Code (E : Entity_Id) is - begin - if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) - and then Present (Size_Check_Code (E)) - then - Remove (Size_Check_Code (E)); - Set_Size_Check_Code (E, Empty); - end if; - end Kill_Size_Check_Code; - -------------------- -- Known_Non_Null -- -------------------- @@ -25336,6 +25429,8 @@ package body Sem_Util is end if; if Nkind (P) = N_Selected_Component + -- and then Ekind (Entity (Selector_Name (P))) + -- in Record_Field_Kind and then Present (Entry_Formal (Entity (Selector_Name (P)))) then -- Case of a reference to an entry formal @@ -26066,6 +26161,24 @@ package body Sem_Util is return Empty; end Param_Entity; + --------------------- + -- Parameter_Count -- + --------------------- + + function Parameter_Count (Subp : Entity_Id) return Nat is + Result : Nat := 0; + Param : Entity_Id; + begin + Param := First_Entity (Subp); + while Present (Param) loop + Result := Result + 1; + + Param := Next_Entity (Param); + end loop; + + return Result; + end Parameter_Count; + ---------------------- -- Policy_In_Effect -- ---------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index fd749c4..38e9676 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -647,6 +647,10 @@ package Sem_Util is -- as Needs_Finalization except with pragma Restrictions (No_Finalization), -- in which case we know that class-wide objects do not need finalization. + function Default_Constructor (Typ : Entity_Id) return Entity_Id; + -- Determine the default constructor (e.g. the constructor with only one + -- formal parameter) for a given type Typ. + function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the @@ -2095,6 +2099,10 @@ package Sem_Util is -- Determine whether arbitrary declaration Decl denotes a generic package, -- a generic subprogram or a generic body. + function Is_In_Context_Clause (N : Node_Id) return Boolean; + -- Returns True if N appears within the context clause of a unit, and False + -- for any other placement. + function Is_Independent_Object (N : Node_Id) return Boolean; -- Determine whether arbitrary node N denotes a reference to an independent -- object as per RM C.6(8). @@ -2377,6 +2385,7 @@ package Sem_Util is -- Pre -- Pre_Class -- Precondition + -- Program_Exit -- Refined_Depends -- Refined_Global -- Refined_Post @@ -2536,12 +2545,6 @@ package Sem_Util is -- if the entity Ent is not for an object. Last_Assignment_Only has the -- same meaning as for the call with no Ent. - procedure Kill_Size_Check_Code (E : Entity_Id); - -- Called when an address clause or pragma Import is applied to an entity. - -- If the entity is a variable or a constant, and size check code is - -- present, this size check code is killed, since the object will not be - -- allocated by the program. - function Known_Non_Null (N : Node_Id) return Boolean; -- Given a node N for a subexpression of an access type, determines if -- this subexpression yields a value that is known at compile time to @@ -2862,6 +2865,9 @@ package Sem_Util is -- WARNING: this routine should be used in debugging scenarios such as -- tracking down undefined symbols as it is fairly low level. + function Parameter_Count (Subp : Entity_Id) return Nat; + -- Return the number of parameters for a given subprogram Subp. + function Param_Entity (N : Node_Id) return Entity_Id; -- Given an expression N, determines if the expression is a reference -- to a formal (of a subprogram or entry), and if so returns the Id diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 35ef616..1bc97a8 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -4670,9 +4670,11 @@ package body Sem_Warn is if Nkind (Parent (LA)) in N_Procedure_Call_Statement | N_Parameter_Association then - Error_Msg_NE - ("?m?& modified by call, but value overwritten #!", - LA, Ent); + if Warn_On_All_Unread_Out_Parameters then + Error_Msg_NE + ("?m?& modified by call, but value overwritten #!", + LA, Ent); + end if; else Error_Msg_NE -- CODEFIX ("?m?useless assignment to&, value overwritten #!", diff --git a/gcc/ada/set_targ.ads b/gcc/ada/set_targ.ads index b2e598f..e465c3f 100644 --- a/gcc/ada/set_targ.ads +++ b/gcc/ada/set_targ.ads @@ -93,7 +93,7 @@ package Set_Targ is type FPT_Mode_Entry is record NAME : String_Ptr; -- Name of mode (no null character at end) - DIGS : Natural; -- Digits for floating-point type + DIGS : Positive; -- Digits for floating-point type FLOAT_REP : Float_Rep_Kind; -- Float representation PRECISION : Natural; -- Precision in bits SIZE : Natural; -- Size in bits diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index d22f103..a0c7314 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -737,14 +737,6 @@ package Sinfo is -- section describes the usage of the semantic fields, which are used to -- contain additional information determined during semantic analysis. - -- Accept_Handler_Records - -- This field is present only in an N_Accept_Alternative node. It is used - -- to temporarily hold the exception handler records from an accept - -- statement in a selective accept. These exception handlers will - -- eventually be placed in the Handler_Records list of the procedure - -- built for this accept (see Expand_N_Selective_Accept procedure in - -- Exp_Ch9 for further details). - -- Access_Types_To_Process -- Present in N_Freeze_Entity nodes for Incomplete or private types. -- Contains the list of access types which may require specific treatment @@ -1515,11 +1507,6 @@ package Sinfo is -- range is given by the programmer, even if that range is identical to -- the range for Float. - -- Incomplete_View - -- Present in full type declarations that are completions of incomplete - -- type declarations. Denotes the corresponding incomplete view declared - -- by the incomplete declaration. - -- Inherited_Discriminant -- This flag is present in N_Component_Association nodes. It indicates -- that a given component association in an extension aggregate is the @@ -1701,6 +1688,7 @@ package Sinfo is -- Pre -- Pre_Class -- Precondition + -- Program_Exit -- Refined_Depends -- Refined_Global -- Refined_Post @@ -6381,7 +6369,6 @@ package Sinfo is -- Condition from the guard (set to Empty if no guard present) -- Statements (set to Empty_List if no statements) -- Pragmas_Before pragmas before alt (set to No_List if none) - -- Accept_Handler_Records ------------------------------ -- 9.7.1 Delay Alternative -- @@ -7966,8 +7953,9 @@ package Sinfo is -- operation) are also in this list. -- Contract_Test_Cases contains a collection of pragmas that correspond - -- to aspects/pragmas Contract_Cases, Exceptional_Cases, Test_Case and - -- Subprogram_Variant. The ordering in the list is in LIFO fashion. + -- to aspects/pragmas Contract_Cases, Exceptional_Cases, Program_Exit, + -- Test_Case and Subprogram_Variant. The ordering in the list is in LIFO + -- fashion. -- Classifications contains pragmas that either declare, categorize, or -- establish dependencies between subprogram or package inputs and diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 0a9602f..49423f0 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -793,8 +793,9 @@ private Full_Ref_Name : File_Name_Type; Instance : Instance_Id; Num_SRef_Pragmas : Nat; - First_Mapped_Line : Logical_Line_Number; Source_Text : Source_Buffer_Ptr; + Inlined_Call : Source_Ptr; + First_Mapped_Line : Logical_Line_Number; Source_First : Source_Ptr; Source_Last : Source_Ptr; Source_Checksum : Word; @@ -803,7 +804,6 @@ private Unit : Unit_Number_Type; Time_Stamp : Time_Stamp_Type; File_Type : Type_Of_File; - Inlined_Call : Source_Ptr; Inlined_Body : Boolean; Inherited_Pragma : Boolean; License : License_Type; @@ -839,52 +839,6 @@ private Index : Source_File_Index := 123456789; -- for debugging end record; - -- The following representation clause ensures that the above record - -- has no holes. We do this so that when instances of this record are - -- written by Tree_Gen, we do not write uninitialized values to the file. - - AS : constant Pos := Standard'Address_Size; - - for Source_File_Record use record - File_Name at 0 range 0 .. 31; - Reference_Name at 4 range 0 .. 31; - Debug_Source_Name at 8 range 0 .. 31; - Full_Debug_Name at 12 range 0 .. 31; - Full_File_Name at 16 range 0 .. 31; - Full_Ref_Name at 20 range 0 .. 31; - Instance at 48 range 0 .. 31; - Num_SRef_Pragmas at 24 range 0 .. 31; - First_Mapped_Line at 28 range 0 .. 31; - Source_First at 32 range 0 .. 31; - Source_Last at 36 range 0 .. 31; - Source_Checksum at 40 range 0 .. 31; - Last_Source_Line at 44 range 0 .. 31; - Template at 52 range 0 .. 31; - Unit at 56 range 0 .. 31; - Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1; - File_Type at 74 range 0 .. 7; - Inlined_Call at 88 range 0 .. 31; - Inlined_Body at 75 range 0 .. 0; - Inherited_Pragma at 75 range 1 .. 1; - License at 76 range 0 .. 7; - Keyword_Casing at 77 range 0 .. 7; - Identifier_Casing at 78 range 0 .. 15; - Sloc_Adjust at 80 range 0 .. 31; - Lines_Table_Max at 84 range 0 .. 31; - Index at 92 range 0 .. 31; - - -- The following fields are pointers, so we have to specialize their - -- lengths using pointer size, obtained above as Standard'Address_Size. - -- Note that Source_Text is a fat pointer, so it has size = AS*2. - - Source_Text at 96 range 0 .. AS * 2 - 1; - Lines_Table at 96 range AS * 2 .. AS * 3 - 1; - Logical_Lines_Table at 96 range AS * 3 .. AS * 4 - 1; - end record; -- Source_File_Record - - for Source_File_Record'Size use 96 * 8 + AS * 4; - -- This ensures that we did not leave out any fields - package Source_File is new Table.Table (Table_Component_Type => Source_File_Record, Table_Index_Type => Source_File_Index, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 95ece32..06d9c4b 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -147,6 +147,7 @@ package Snames is -- Names of aspects for which there are no matching pragmas or attributes -- so that they need to be included for aspect specification use. + Name_Constructor : constant Name_Id := N + $; Name_Default_Value : constant Name_Id := N + $; Name_Default_Component_Value : constant Name_Id := N + $; Name_Designated_Storage_Model : constant Name_Id := N + $; @@ -659,6 +660,7 @@ package Snames is -- correctly recognize and process Priority. Priority is a standard Ada 95 -- pragma. + Name_Program_Exit : constant Name_Id := N + $; -- GNAT Name_Provide_Shift_Operators : constant Name_Id := N + $; -- GNAT Name_Psect_Object : constant Name_Id := N + $; -- GNAT Name_Pure : constant Name_Id := N + $; @@ -1080,6 +1082,7 @@ package Snames is Name_Img : constant Name_Id := N + $; -- GNAT Name_Input : constant Name_Id := N + $; Name_Machine : constant Name_Id := N + $; + Name_Make : constant Name_Id := N + $; -- GNAT Name_Max : constant Name_Id := N + $; Name_Min : constant Name_Id := N + $; Name_Model : constant Name_Id := N + $; @@ -1614,6 +1617,7 @@ package Snames is Attribute_Img, Attribute_Input, Attribute_Machine, + Attribute_Make, Attribute_Max, Attribute_Min, Attribute_Model, @@ -1952,6 +1956,7 @@ package Snames is Pragma_Predicate_Failure, Pragma_Preelaborate, Pragma_Pre_Class, + Pragma_Program_Exit, Pragma_Provide_Shift_Operators, Pragma_Psect_Object, Pragma_Pure, diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 6344a0b..1e54340 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -335,6 +335,7 @@ package body Switch.C is end if; Ptr := Ptr + 1; + Check_Semantics_Only_Mode := True; Operating_Mode := Check_Semantics; -- -gnatC (Generate CodePeer information) diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 04ca270..3dc76f9 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -331,7 +331,7 @@ __gnat_ttyname (int filedes ATTRIBUTE_UNUSED) #endif /* defined (__vxworks) */ } #endif - + #if defined (__linux__) || defined (__sun__) \ || defined (WINNT) \ || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ @@ -1070,6 +1070,11 @@ _getpagesize (void) { return getpagesize (); } + +int +__gnat_has_cap_sys_nice () { + return 0; +} #endif int diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb index cad1e66..d5fb4f5 100644 --- a/gcc/ada/urealp.adb +++ b/gcc/ada/urealp.adb @@ -34,7 +34,7 @@ package body Urealp is -- add 1 to No_Ureal, since "+" means something different for Ureals). type Ureal_Entry is record - Num : Uint; + Num : Uint; -- Numerator (always non-negative) Den : Uint; @@ -48,20 +48,6 @@ package body Urealp is -- Flag set if value is negative end record; - -- The following representation clause ensures that the above record - -- has no holes. We do this so that when instances of this record are - -- written, we do not write uninitialized values to the file. - - for Ureal_Entry use record - Num at 0 range 0 .. 31; - Den at 4 range 0 .. 31; - Rbase at 8 range 0 .. 31; - Negative at 12 range 0 .. 31; - end record; - - for Ureal_Entry'Size use 16 * 8; - -- This ensures that we did not leave out any fields - package Ureals is new Table.Table ( Table_Component_Type => Ureal_Entry, Table_Index_Type => Ureal'Base, @@ -832,7 +818,7 @@ package body Urealp is return Store_Ureal ((Num => Uint_1, Den => -N, - Rbase => UI_To_Int (UR_Trunc (Bas)), + Rbase => UI_To_Int (IBas), Negative => Neg)); -- If the exponent is negative then we raise the numerator and the @@ -1251,12 +1237,13 @@ package body Urealp is --------------- function UR_Negate (Real : Ureal) return Ureal is + Val : constant Ureal_Entry := Ureals.Table (Real); begin return Store_Ureal - ((Num => Ureals.Table (Real).Num, - Den => Ureals.Table (Real).Den, - Rbase => Ureals.Table (Real).Rbase, - Negative => not Ureals.Table (Real).Negative)); + ((Num => Val.Num, + Den => Val.Den, + Rbase => Val.Rbase, + Negative => not Val.Negative)); end UR_Negate; ------------ diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads index 323efc8..c7725bf 100644 --- a/gcc/ada/urealp.ads +++ b/gcc/ada/urealp.ads @@ -233,7 +233,7 @@ package Urealp is function UR_Sub (Left : Ureal; Right : Uint) return Ureal; -- Returns real difference of operands - function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal; + function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal; -- Returns result of raising Ureal to Uint power. -- Fatal error if Left is 0 and Right is negative. @@ -317,7 +317,7 @@ package Urealp is function "-" (Left : Uint; Right : Ureal) return Ureal renames UR_Sub; function "-" (Left : Ureal; Right : Uint) return Ureal renames UR_Sub; - function "**" (Real : Ureal; N : Uint) return Ureal + function "**" (Real : Ureal; N : Uint) return Ureal renames UR_Exponentiate; function "abs" (Real : Ureal) return Ureal renames UR_Abs; diff --git a/gcc/auto-profile.cc b/gcc/auto-profile.cc index 91cc8db..8940d1f2 100644 --- a/gcc/auto-profile.cc +++ b/gcc/auto-profile.cc @@ -35,6 +35,8 @@ along with GCC; see the file COPYING3. If not see #include "diagnostic-core.h" #include "profile.h" #include "langhooks.h" +#include "context.h" +#include "pass_manager.h" #include "cfgloop.h" #include "tree-cfg.h" #include "tree-cfgcleanup.h" @@ -858,6 +860,9 @@ autofdo_source_profile::read () /* Read in the function/callsite profile, and store it in local data structure. */ unsigned function_num = gcov_read_unsigned (); + int profile_pass_num + = g->get_passes ()->get_pass_auto_profile ()->static_pass_number; + g->get_dumps ()->dump_start (profile_pass_num, NULL); for (unsigned i = 0; i < function_num; i++) { function_instance::function_instance_stack stack; @@ -870,8 +875,21 @@ autofdo_source_profile::read () if (map_.count (fun_id) == 0) map_[fun_id] = s; else - map_[fun_id]->merge (s); + { + /* Since this is invoked very early, before the pass + manager, we need to set up the dumping explicitly. This is + similar to the handling in finish_optimization_passes. */ + if (dump_enabled_p ()) + { + dump_user_location_t loc + = dump_user_location_t::from_location_t (input_location); + dump_printf_loc (MSG_NOTE, loc, "Merging profile for %s\n", + afdo_string_table->get_name (s->name ())); + } + map_[fun_id]->merge (s); + } } + g->get_dumps ()->dump_finish (profile_pass_num); return true; } @@ -1102,7 +1120,8 @@ update_count_by_afdo_count (profile_count *count, gcov_type c) /* In case we have guessed profile which is already zero, preserve quality info. */ else if (count->nonzero_p () - || count->quality () == GUESSED) + || count->quality () == GUESSED + || count->quality () == GUESSED_LOCAL) *count = profile_count::zero ().afdo (); } @@ -1497,8 +1516,21 @@ afdo_calculate_branch_prob (bb_set *annotated_bb) if (num_unknown_succ == 0 && total_count.nonzero_p ()) { FOR_EACH_EDGE (e, ei, bb->succs) - e->probability - = AFDO_EINFO (e)->get_count ().probability_in (total_count); + { + /* If probability is 1, preserve reliable static prediction + (This is, for example the case of single fallthru edge + or single fallthru plus unlikely EH edge.) */ + if (AFDO_EINFO (e)->get_count () == total_count + && e->probability == profile_probability::always ()) + ; + else if (AFDO_EINFO (e)->get_count ().nonzero_p ()) + e->probability + = AFDO_EINFO (e)->get_count ().probability_in (total_count); + /* If probability is zero, preserve reliable static prediction. */ + else if (e->probability.nonzero_p () + || e->probability.quality () == GUESSED) + e->probability = profile_probability::never ().afdo (); + } } } FOR_ALL_BB_FN (bb, cfun) diff --git a/gcc/c-family/ChangeLog b/gcc/c-family/ChangeLog index f543372..cd96e82 100644 --- a/gcc/c-family/ChangeLog +++ b/gcc/c-family/ChangeLog @@ -1,3 +1,8 @@ +2025-06-03 Martin Uecker <uecker@tugraz.at> + + PR c/120078 + * c.opt (Wjump-misses-init): Fix typo. + 2025-05-30 Julian Brown <julian@codesourcery.com> Tobias Burnus <tburnus@baylibre.com> diff --git a/gcc/c-family/c.opt b/gcc/c-family/c.opt index 75b6531..50ba856 100644 --- a/gcc/c-family/c.opt +++ b/gcc/c-family/c.opt @@ -938,7 +938,7 @@ C ObjC C++ ObjC++ CPP(cpp_warn_invalid_utf8) CppReason(CPP_W_INVALID_UTF8) Var(w Warn about invalid UTF-8 characters. Wjump-misses-init -C ObjC Var(warn_jump_misses_init) Warning LangEnabledby(C ObjC,Wc++-compat) +C ObjC Var(warn_jump_misses_init) Warning LangEnabledBy(C ObjC,Wc++-compat) Warn when a jump misses a variable initialization. Enum diff --git a/gcc/c/ChangeLog b/gcc/c/ChangeLog index 53ad780..7f5b0b8 100644 --- a/gcc/c/ChangeLog +++ b/gcc/c/ChangeLog @@ -1,3 +1,13 @@ +2025-06-03 Martin Uecker <uecker@tugraz.at> + + * c-typeck.cc (composite_type_internal,composite_type): Move + checking assertions. + +2025-06-03 Martin Uecker <uecker@tugraz.at> + + PR c/116892 + * c-decl.cc (finish_enum): Propagate TYPE_PACKED. + 2025-06-02 Sandra Loosemore <sloosemore@baylibre.com> * c-parser.cc (c_parser_omp_context_selector): Call diff --git a/gcc/c/c-decl.cc b/gcc/c/c-decl.cc index 1008bca..2b0bd66 100644 --- a/gcc/c/c-decl.cc +++ b/gcc/c/c-decl.cc @@ -10293,6 +10293,7 @@ finish_enum (tree enumtype, tree values, tree attributes) TYPE_UNSIGNED (tem) = TYPE_UNSIGNED (enumtype); TYPE_LANG_SPECIFIC (tem) = TYPE_LANG_SPECIFIC (enumtype); ENUM_UNDERLYING_TYPE (tem) = ENUM_UNDERLYING_TYPE (enumtype); + TYPE_PACKED (tem) = TYPE_PACKED (enumtype); } /* Finish debugging output for this type. */ diff --git a/gcc/c/c-typeck.cc b/gcc/c/c-typeck.cc index 2f243ca..b59b5c8a 100644 --- a/gcc/c/c-typeck.cc +++ b/gcc/c/c-typeck.cc @@ -846,12 +846,7 @@ composite_type_internal (tree t1, tree t2, struct composite_cache* cache) n = finish_struct (input_location, n, fields, attributes, NULL, &expr); - n = qualify_type (n, t1); - - gcc_checking_assert (!TYPE_NAME (n) || comptypes (n, t1)); - gcc_checking_assert (!TYPE_NAME (n) || comptypes (n, t2)); - - return n; + return qualify_type (n, t1); } /* FALLTHRU */ case ENUMERAL_TYPE: @@ -1004,7 +999,15 @@ tree composite_type (tree t1, tree t2) { struct composite_cache cache = { }; - return composite_type_internal (t1, t2, &cache); + tree n = composite_type_internal (t1, t2, &cache); + /* For function and arrays there are some cases where qualifiers do + not match. See PR120510. */ + if (FUNCTION_TYPE != TREE_CODE (n) && ARRAY_TYPE != TREE_CODE (n)) + { + gcc_checking_assert (comptypes (n, t1)); + gcc_checking_assert (comptypes (n, t2)); + } + return n; } /* Return the type of a conditional expression between pointers to diff --git a/gcc/calls.cc b/gcc/calls.cc index 164f3c5..e16190c 100644 --- a/gcc/calls.cc +++ b/gcc/calls.cc @@ -3736,19 +3736,16 @@ expand_call (tree exp, rtx target, int ignore) next_arg_reg, valreg, old_inhibit_defer_pop, call_fusage, flags, args_so_far); - if (flag_ipa_ra) + rtx_call_insn *last; + rtx datum = NULL_RTX; + if (fndecl != NULL_TREE) { - rtx_call_insn *last; - rtx datum = NULL_RTX; - if (fndecl != NULL_TREE) - { - datum = XEXP (DECL_RTL (fndecl), 0); - gcc_assert (datum != NULL_RTX - && GET_CODE (datum) == SYMBOL_REF); - } - last = last_call_insn (); - add_reg_note (last, REG_CALL_DECL, datum); + datum = XEXP (DECL_RTL (fndecl), 0); + gcc_assert (datum != NULL_RTX + && GET_CODE (datum) == SYMBOL_REF); } + last = last_call_insn (); + add_reg_note (last, REG_CALL_DECL, datum); /* If the call setup or the call itself overlaps with anything of the argument setup we probably clobbered our call address. @@ -4804,13 +4801,10 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, struct_value_size, call_cookie, valreg, old_inhibit_defer_pop + 1, call_fusage, flags, args_so_far); - if (flag_ipa_ra) - { - rtx datum = orgfun; - gcc_assert (GET_CODE (datum) == SYMBOL_REF); - rtx_call_insn *last = last_call_insn (); - add_reg_note (last, REG_CALL_DECL, datum); - } + rtx datum = orgfun; + gcc_assert (GET_CODE (datum) == SYMBOL_REF); + rtx_call_insn *last = last_call_insn (); + add_reg_note (last, REG_CALL_DECL, datum); /* Right-shift returned value if necessary. */ if (!pcc_struct_value diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index 03243e9..e4d7a1e 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,16 @@ +2025-06-05 Robert Dubner <rdubner@symas.com> + + PR cobol/119975 + * genapi.cc (parser_intrinsic_call_0): Use get_time_nanoseconds(). + * genutil.cc (get_time_64): Rename to get_time_nanoseconds(). + (get_time_nanoseconds): Likewise. + * genutil.h (get_time_64): Likewise. + (get_time_nanoseconds): Likewise. + * util.cc (class cbl_timespec): Timing routine uses + get_time_nanoseconds(). + (operator-): Likewise. + (parse_file): Likewise. + 2025-06-02 Robert Dubner <rdubner@symas.com> PR cobol/119975 diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 5e983ab..bde8151 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -10491,7 +10491,7 @@ parser_intrinsic_call_0(cbl_field_t *tgt, { // Pass __gg__when_compiled() the time from right now. struct timespec tp; - uint64_t now = get_time_64(); + uint64_t now = get_time_nanoseconds(); tp.tv_sec = now / 1000000000; tp.tv_nsec = now % 1000000000; diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index e971043..f1098f0 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -2121,7 +2121,7 @@ qualified_data_location(cbl_refer_t &refer) } uint64_t -get_time_64() +get_time_nanoseconds() { // This code was unabashedly stolen from gcc/timevar.cc. // It returns the Unix epoch with nine decimal places. diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index 43102d7..fb582e5 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -155,7 +155,7 @@ void build_array_of_fourplets( int ngroup, size_t N, cbl_refer_t *refers); void get_depending_on_value_from_odo(tree retval, cbl_field_t *odo); -uint64_t get_time_64(); +uint64_t get_time_nanoseconds(); #endif diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 75a0b26..e92f069 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -65,6 +65,7 @@ #include "inspect.h" #include "../../libgcobol/io.h" #include "genapi.h" +#include "genutil.h" #pragma GCC diagnostic ignored "-Wunused-result" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -2141,22 +2142,25 @@ cobol_fileline_set( const char line[] ) { return file.name; } +//#define TIMING_PARSE +#ifdef TIMING_PARSE class cbl_timespec { - struct timespec now; + uint64_t now; // Nanoseconds public: cbl_timespec() { - clock_gettime(CLOCK_MONOTONIC, &now); + now = get_time_nanoseconds(); } double ns() const { - return now.tv_sec * 1000000000 + now.tv_nsec; + return now; } friend double operator-( const cbl_timespec& now, const cbl_timespec& then ); }; double -operator-( const cbl_timespec& then, const cbl_timespec& now ) { +operator-( const cbl_timespec& now, const cbl_timespec& then ) { return (now.ns() - then.ns()) / 1000000000; } +#endif static int parse_file( const char filename[] ) @@ -2172,15 +2176,20 @@ parse_file( const char filename[] ) return 0; } +#ifdef TIMING_PARSE cbl_timespec start; +#endif int erc = yyparse(); +#ifdef TIMING_PARSE cbl_timespec finish; double dt = finish - start; + printf("Overall parse & generate time is %.6f seconds\n", dt); +#endif + parser_leave_file(); - //printf("Overall parse & generate time is %.6f seconds\n", dt); fclose (yyin); diff --git a/gcc/common/config/riscv/riscv-common.cc b/gcc/common/config/riscv/riscv-common.cc index a6d8763..6b54403 100644 --- a/gcc/common/config/riscv/riscv-common.cc +++ b/gcc/common/config/riscv/riscv-common.cc @@ -1129,8 +1129,10 @@ riscv_subset_list::check_implied_ext () void riscv_subset_list::handle_combine_ext () { - for (const auto &[ext_name, ext_info] : riscv_ext_infos) + for (const auto &pair : riscv_ext_infos) { + const std::string &ext_name = pair.first; + auto &ext_info = pair.second; bool is_combined = true; /* Skip if this extension don't need to combine. */ if (!ext_info.need_combine_p ()) @@ -1558,20 +1560,27 @@ riscv_set_arch_by_subset_list (riscv_subset_list *subset_list, if (opts) { /* Clean up target flags before we set. */ - for (const auto &[ext_name, ext_info] : riscv_ext_infos) - ext_info.clean_opts (opts); + for (const auto &pair : riscv_ext_infos) + { + auto &ext_info = pair.second; + ext_info.clean_opts (opts); + } if (subset_list->xlen () == 32) opts->x_riscv_isa_flags &= ~MASK_64BIT; else if (subset_list->xlen () == 64) opts->x_riscv_isa_flags |= MASK_64BIT; - for (const auto &[ext_name, ext_info] : riscv_ext_infos) - if (subset_list->lookup (ext_name.c_str ())) - { - /* Set the extension flag. */ - ext_info.set_opts (opts); - } + for (const auto &pair : riscv_ext_infos) + { + const std::string &ext_name = pair.first; + auto &ext_info = pair.second; + if (subset_list->lookup (ext_name.c_str ())) + { + /* Set the extension flag. */ + ext_info.set_opts (opts); + } + } } } diff --git a/gcc/config.gcc b/gcc/config.gcc index 1e386a4..8365b91 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -4611,15 +4611,13 @@ case "${target}" in for which in arch tune; do eval "val=\$with_$which" - case ${val} in - "" | gfx900 | gfx906 | gfx908 | gfx90a | gfx90c | gfx1030 | gfx1036 | gfx1100 | gfx1103) - # OK - ;; - *) + if test x"$val" != x \ + && ! grep -q "GCN_DEVICE($val," \ + "${srcdir}/config/gcn/gcn-devices.def"; + then echo "Unknown cpu used in --with-$which=$val." 1>&2 exit 1 - ;; - esac + fi done [ "x$with_arch" = x ] && with_arch=gfx900 diff --git a/gcc/config/aarch64/aarch64-sve-builtins.cc b/gcc/config/aarch64/aarch64-sve-builtins.cc index 3651926..2b627a9 100644 --- a/gcc/config/aarch64/aarch64-sve-builtins.cc +++ b/gcc/config/aarch64/aarch64-sve-builtins.cc @@ -47,6 +47,8 @@ #include "langhooks.h" #include "stringpool.h" #include "attribs.h" +#include "value-range.h" +#include "tree-ssanames.h" #include "aarch64-sve-builtins.h" #include "aarch64-sve-builtins-base.h" #include "aarch64-sve-builtins-sve2.h" @@ -3664,7 +3666,8 @@ gimple_folder::fold_pfalse () /* Convert the lhs and all non-boolean vector-type operands to TYPE. Pass the converted variables to the callback FP, and finally convert the result back to the original type. Add the necessary conversion statements. - Return the new call. */ + Return the new call. Note the tree argument to the callback FP, can only + be set once; it will always be a SSA_NAME. */ gimple * gimple_folder::convert_and_fold (tree type, gimple *(*fp) (gimple_folder &, @@ -3675,7 +3678,7 @@ gimple_folder::convert_and_fold (tree type, tree old_ty = TREE_TYPE (lhs); gimple_seq stmts = NULL; bool convert_lhs_p = !useless_type_conversion_p (type, old_ty); - tree lhs_conv = convert_lhs_p ? create_tmp_var (type) : lhs; + tree lhs_conv = convert_lhs_p ? make_ssa_name (type) : lhs; unsigned int num_args = gimple_call_num_args (call); auto_vec<tree, 16> args_conv; args_conv.safe_grow (num_args); diff --git a/gcc/config/i386/i386.md b/gcc/config/i386/i386.md index b7a18d5..8eee447 100644 --- a/gcc/config/i386/i386.md +++ b/gcc/config/i386/i386.md @@ -8719,6 +8719,34 @@ (set (match_dup 1) (minus:SWI (match_dup 1) (match_dup 0)))])]) +;; Under APX NDD, 'sub reg, mem, reg' is valid. +;; New format for +;; mov reg0, mem1 +;; sub reg0, mem2, reg0 +;; mov mem2, reg0 +;; to +;; mov reg0, mem1 +;; sub mem2, reg0 +(define_peephole2 + [(set (match_operand:SWI 0 "general_reg_operand") + (match_operand:SWI 1 "memory_operand")) + (parallel [(set (reg:CC FLAGS_REG) + (compare:CC (match_operand:SWI 2 "memory_operand") + (match_dup 0))) + (set (match_dup 0) + (minus:SWI (match_dup 2) (match_dup 0)))]) + (set (match_dup 2) (match_dup 0))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (3, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2])" + [(set (match_dup 0) (match_dup 1)) + (parallel [(set (reg:CC FLAGS_REG) + (compare:CC (match_dup 2) (match_dup 0))) + (set (match_dup 2) + (minus:SWI (match_dup 2) (match_dup 0)))])]) + ;; decl %eax; cmpl $-1, %eax; jne .Lxx; can be optimized into ;; subl $1, %eax; jnc .Lxx; (define_peephole2 @@ -9166,6 +9194,118 @@ (match_dup 1)) (match_dup 0)))])]) +;; Under APX NDD, 'adc reg, mem, reg' is valid. +;; +;; New format for +;; mov reg0, mem1 +;; adc reg0, mem2, reg0 +;; mov mem1, reg0 +;; to +;; mov reg0, mem2 +;; adc mem1, reg0 +(define_peephole2 + [(set (match_operand:SWI48 0 "general_reg_operand") + (match_operand:SWI48 1 "memory_operand")) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> + (plus:SWI48 + (plus:SWI48 + (match_operator:SWI48 5 "ix86_carry_flag_operator" + [(match_operand 3 "flags_reg_operand") + (const_int 0)]) + (match_operand:SWI48 2 "memory_operand")) + (match_dup 0))) + (plus:<DWI> + (match_operator:<DWI> 4 "ix86_carry_flag_operator" + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 0) + (plus:SWI48 (plus:SWI48 (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 2)) + (match_dup 0)))]) + (set (match_dup 1) (match_dup 0))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (3, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2])" + [(set (match_dup 0) (match_dup 2)) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> + (plus:SWI48 + (plus:SWI48 + (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 1)) + (match_dup 0))) + (plus:<DWI> + (match_op_dup 4 + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 1) + (plus:SWI48 (plus:SWI48 (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 1)) + (match_dup 0)))])]) + +;; New format for +;; mov reg0, mem1 +;; adc reg0, mem2, reg0 +;; mov mem2, reg0 +;; to +;; mov reg0, mem1 +;; adc mem2, reg0 +(define_peephole2 + [(set (match_operand:SWI48 0 "general_reg_operand") + (match_operand:SWI48 1 "memory_operand")) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> + (plus:SWI48 + (plus:SWI48 + (match_operator:SWI48 5 "ix86_carry_flag_operator" + [(match_operand 3 "flags_reg_operand") + (const_int 0)]) + (match_operand:SWI48 2 "memory_operand")) + (match_dup 0))) + (plus:<DWI> + (match_operator:<DWI> 4 "ix86_carry_flag_operator" + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 0) + (plus:SWI48 (plus:SWI48 (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 2)) + (match_dup 0)))]) + (set (match_dup 2) (match_dup 0))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (3, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2])" + [(set (match_dup 0) (match_dup 1)) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> + (plus:SWI48 + (plus:SWI48 + (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 2)) + (match_dup 0))) + (plus:<DWI> + (match_op_dup 4 + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 2) + (plus:SWI48 (plus:SWI48 (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 2)) + (match_dup 0)))])]) + (define_peephole2 [(parallel [(set (reg:CCC FLAGS_REG) (compare:CCC @@ -9646,6 +9786,52 @@ [(match_dup 3) (const_int 0)])) (match_dup 0)))])]) +;; Under APX NDD, 'sbb reg, mem, reg' is valid. +;; +;; New format for +;; mov reg0, mem1 +;; sbb reg0, mem2, reg0 +;; mov mem2, reg0 +;; to +;; mov reg0, mem1 +;; sbb mem2, reg0 +(define_peephole2 + [(set (match_operand:SWI48 0 "general_reg_operand") + (match_operand:SWI48 1 "memory_operand")) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> (match_operand:SWI48 2 "memory_operand")) + (plus:<DWI> + (match_operator:<DWI> 4 "ix86_carry_flag_operator" + [(match_operand 3 "flags_reg_operand") (const_int 0)]) + (zero_extend:<DWI> + (match_dup 0))))) + (set (match_dup 0) + (minus:SWI48 + (minus:SWI48 + (match_dup 2) + (match_operator:SWI48 5 "ix86_carry_flag_operator" + [(match_dup 3) (const_int 0)])) + (match_dup 0)))]) + (set (match_dup 2) (match_dup 0))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (3, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2])" + [(set (match_dup 0) (match_dup 1)) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> (match_dup 2)) + (plus:<DWI> (match_op_dup 4 + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 2) + (minus:SWI48 (minus:SWI48 (match_dup 2) + (match_op_dup 5 + [(match_dup 3) (const_int 0)])) + (match_dup 0)))])]) + (define_peephole2 [(set (match_operand:SWI48 6 "general_reg_operand") (match_operand:SWI48 7 "memory_operand")) @@ -26292,8 +26478,8 @@ (define_expand "mov<mode>cc" [(set (match_operand:SWIM 0 "register_operand") (if_then_else:SWIM (match_operand 1 "comparison_operator") - (match_operand:SWIM 2 "<general_operand>") - (match_operand:SWIM 3 "<general_operand>")))] + (match_operand:SWIM 2 "general_operand") + (match_operand:SWIM 3 "general_operand")))] "" "if (ix86_expand_int_movcc (operands)) DONE; else FAIL;") @@ -28212,6 +28398,41 @@ const0_rtx); }) +;; For APX NDD PLUS/MINUS/LOGIC +;; Like cmpelim optimized pattern. +;; Reduce an extra mov instruction like +;; decl (%rdi), %eax +;; mov %eax, (%rdi) +;; to +;; decl (%rdi) +(define_peephole2 + [(parallel [(set (reg FLAGS_REG) + (compare (match_operator:SWI 2 "plusminuslogic_operator" + [(match_operand:SWI 0 "memory_operand") + (match_operand:SWI 1 "<nonmemory_operand>")]) + (const_int 0))) + (set (match_operand:SWI 3 "register_operand") (match_dup 2))]) + (set (match_dup 0) (match_dup 3))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (2, operands[3]) + && !reg_overlap_mentioned_p (operands[3], operands[0]) + && ix86_match_ccmode (peep2_next_insn (0), + (GET_CODE (operands[2]) == PLUS + || GET_CODE (operands[2]) == MINUS) + ? CCGOCmode : CCNOmode)" + [(parallel [(set (match_dup 4) (match_dup 6)) + (set (match_dup 0) (match_dup 5))])] +{ + operands[4] = SET_DEST (XVECEXP (PATTERN (peep2_next_insn (0)), 0, 0)); + operands[5] + = gen_rtx_fmt_ee (GET_CODE (operands[2]), GET_MODE (operands[2]), + copy_rtx (operands[0]), operands[1]); + operands[6] + = gen_rtx_COMPARE (GET_MODE (operands[4]), copy_rtx (operands[5]), + const0_rtx); +}) + ;; Likewise for instances where we have a lea pattern. (define_peephole2 [(set (match_operand:SWI 0 "register_operand") @@ -28305,6 +28526,54 @@ const0_rtx); }) +;; For APX NDD XOR +;; Reduce 2 mov and 1 cmp instruction. +;; from +;; movq (%rdi), %rax +;; xorq %rsi, %rax, %rdx +;; movb %rdx, (%rdi) +;; cmpb %rsi, %rax +;; jne +;; to +;; xorb %rsi, (%rdi) +;; jne +(define_peephole2 + [(set (match_operand:SWI 0 "register_operand") + (match_operand:SWI 1 "memory_operand")) + (parallel [(set (match_operand:SWI 4 "register_operand") + (xor:SWI (match_operand:SWI 3 "register_operand") + (match_operand:SWI 2 "<nonmemory_operand>"))) + (clobber (reg:CC FLAGS_REG))]) + (set (match_dup 1) (match_dup 4)) + (set (reg:CCZ FLAGS_REG) + (compare:CCZ (match_operand:SWI 5 "register_operand") + (match_operand:SWI 6 "<nonmemory_operand>")))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && REGNO (operands[3]) == REGNO (operands[0]) + && (rtx_equal_p (operands[0], operands[5]) + ? rtx_equal_p (operands[2], operands[6]) + : rtx_equal_p (operands[2], operands[5]) + && rtx_equal_p (operands[0], operands[6])) + && peep2_reg_dead_p (3, operands[4]) + && peep2_reg_dead_p (4, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2]) + && (<MODE>mode != QImode + || immediate_operand (operands[2], QImode) + || any_QIreg_operand (operands[2], QImode))" + [(parallel [(set (match_dup 7) (match_dup 9)) + (set (match_dup 1) (match_dup 8))])] +{ + operands[7] = SET_DEST (PATTERN (peep2_next_insn (3))); + operands[8] = gen_rtx_XOR (<MODE>mode, copy_rtx (operands[1]), + operands[2]); + operands[9] + = gen_rtx_COMPARE (GET_MODE (operands[7]), + copy_rtx (operands[8]), + const0_rtx); +}) + (define_peephole2 [(set (match_operand:SWI12 0 "register_operand") (match_operand:SWI12 1 "memory_operand")) @@ -28548,6 +28817,58 @@ const0_rtx); }) +;; For APX NDD XOR +;; Reduce 2 mov and 1 cmp instruction. +;; from +;; movb (%rdi), %al +;; xorl %esi, %eax, %edx +;; movb %dl, (%rdi) +;; cmpb %sil, %al +;; jne +;; to +;; xorl %sil, (%rdi) +;; jne +(define_peephole2 + [(set (match_operand:SWI12 0 "register_operand") + (match_operand:SWI12 1 "memory_operand")) + (parallel [(set (match_operand:SI 4 "register_operand") + (xor:SI (match_operand:SI 3 "register_operand") + (match_operand:SI 2 "<nonmemory_operand>"))) + (clobber (reg:CC FLAGS_REG))]) + (set (match_dup 1) (match_operand:SWI12 5 "register_operand")) + (set (reg:CCZ FLAGS_REG) + (compare:CCZ (match_operand:SWI12 6 "register_operand") + (match_operand:SWI12 7 "<nonmemory_operand>")))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && REGNO (operands[3]) == REGNO (operands[0]) + && REGNO (operands[5]) == REGNO (operands[4]) + && (rtx_equal_p (operands[0], operands[6]) + ? (REG_P (operands[2]) + ? REG_P (operands[7]) && REGNO (operands[2]) == REGNO (operands[7]) + : rtx_equal_p (operands[2], operands[7])) + : (rtx_equal_p (operands[0], operands[7]) + && REG_P (operands[2]) + && REGNO (operands[2]) == REGNO (operands[6]))) + && peep2_reg_dead_p (3, operands[5]) + && peep2_reg_dead_p (4, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2]) + && (<MODE>mode != QImode + || immediate_operand (operands[2], SImode) + || any_QIreg_operand (operands[2], SImode))" + [(parallel [(set (match_dup 8) (match_dup 10)) + (set (match_dup 1) (match_dup 9))])] +{ + operands[8] = SET_DEST (PATTERN (peep2_next_insn (3))); + operands[9] = gen_rtx_XOR (<MODE>mode, copy_rtx (operands[1]), + gen_lowpart (<MODE>mode, operands[2])); + operands[10] + = gen_rtx_COMPARE (GET_MODE (operands[8]), + copy_rtx (operands[9]), + const0_rtx); +}) + ;; Attempt to optimize away memory stores of values the memory already ;; has. See PR79593. (define_peephole2 diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index aea5e2c..c40b0fd 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -13418,7 +13418,7 @@ (const_int 6) (const_int 14)])))] "TARGET_AVX512F" "vmovddup\t{%1, %0<mask_operand2>|%0<mask_operand2>, %1}" - [(set_attr "type" "sselog1") + [(set_attr "type" "ssemov") (set_attr "prefix" "evex") (set_attr "mode" "V8DF")]) @@ -13449,7 +13449,7 @@ (const_int 2) (const_int 6)])))] "TARGET_AVX && <mask_avx512vl_condition>" "vmovddup\t{%1, %0<mask_operand2>|%0<mask_operand2>, %1}" - [(set_attr "type" "sselog1") + [(set_attr "type" "ssemov") (set_attr "prefix" "<mask_prefix>") (set_attr "mode" "V4DF")]) @@ -27839,7 +27839,7 @@ %vmovddup\t{%1, %0|%0, %1} movlhps\t%0, %0" [(set_attr "isa" "sse2_noavx,avx,avx512f,sse3,noavx") - (set_attr "type" "sselog1,sselog1,ssemov,sselog1,ssemov") + (set_attr "type" "sselog1,sselog1,ssemov,ssemov,ssemov") (set_attr "prefix" "orig,maybe_evex,evex,maybe_vex,orig") (set (attr "mode") (cond [(and (eq_attr "alternative" "2") diff --git a/gcc/config/nvptx/mkoffload.cc b/gcc/config/nvptx/mkoffload.cc index e7ec0ef..bb3f0fc 100644 --- a/gcc/config/nvptx/mkoffload.cc +++ b/gcc/config/nvptx/mkoffload.cc @@ -260,8 +260,10 @@ process (FILE *in, FILE *out, uint32_t omp_requires) unsigned ix; const char *sm_ver = NULL, *version = NULL; const char *sm_ver2 = NULL, *version2 = NULL; - size_t file_cnt = 0; - size_t *file_idx = XALLOCAVEC (size_t, len); + /* To reduce the number of reallocations for 'file_idx', guess 'file_cnt' + (very roughly...), based on 'len'. */ + const size_t file_cnt_guessed = 13 + len / 27720; + auto_vec<size_t> file_idx (file_cnt_guessed); fprintf (out, "#include <stdint.h>\n\n"); @@ -269,9 +271,10 @@ process (FILE *in, FILE *out, uint32_t omp_requires) terminated by a NUL. */ for (size_t i = 0; i != len;) { + file_idx.safe_push (i); + char c; bool output_fn_ptr = false; - file_idx[file_cnt++] = i; fprintf (out, "static const char ptx_code_%u[] =\n\t\"", obj_count++); while ((c = input[i++])) @@ -349,6 +352,9 @@ process (FILE *in, FILE *out, uint32_t omp_requires) } } + const size_t file_cnt = file_idx.length (); + gcc_checking_assert (file_cnt == obj_count); + /* Create function-pointer array, required for reverse offload function-pointer lookup. */ diff --git a/gcc/config/riscv/autovec-opt.md b/gcc/config/riscv/autovec-opt.md index a972eda..4465eb2 100644 --- a/gcc/config/riscv/autovec-opt.md +++ b/gcc/config/riscv/autovec-opt.md @@ -1682,7 +1682,7 @@ ;; ============================================================================= (define_insn_and_split "*<optab>_vx_<mode>" [(set (match_operand:V_VLSI 0 "register_operand") - (any_int_binop_no_shift_vx:V_VLSI + (any_int_binop_no_shift_vdup_v:V_VLSI (vec_duplicate:V_VLSI (match_operand:<VEL> 1 "register_operand")) (match_operand:V_VLSI 2 "<binop_rhs2_predicate>")))] @@ -1699,7 +1699,7 @@ (define_insn_and_split "*<optab>_vx_<mode>" [(set (match_operand:V_VLSI 0 "register_operand") - (any_int_binop_no_shift_vx:V_VLSI + (any_int_binop_no_shift_v_vdup:V_VLSI (match_operand:V_VLSI 1 "<binop_rhs2_predicate>") (vec_duplicate:V_VLSI (match_operand:<VEL> 2 "register_operand"))))] @@ -1713,3 +1713,55 @@ <MODE>mode); } [(set_attr "type" "vialu")]) + +;; ============================================================================= +;; Combine vec_duplicate + op.vv to op.vf +;; Include +;; - vfmadd.vf +;; - vfmsub.vf +;; ============================================================================= + + +(define_insn_and_split "*<optab>_vf_<mode>" + [(set (match_operand:V_VLSF 0 "register_operand" "=vd") + (plus_minus:V_VLSF + (mult:V_VLSF + (vec_duplicate:V_VLSF + (match_operand:<VEL> 1 "register_operand" " f")) + (match_operand:V_VLSF 2 "register_operand" " 0")) + (match_operand:V_VLSF 3 "register_operand" " vr")))] + "TARGET_VECTOR && can_create_pseudo_p ()" + "#" + "&& 1" + [(const_int 0)] + { + rtx ops[] = {operands[0], operands[1], operands[2], operands[3], + operands[2]}; + riscv_vector::emit_vlmax_insn (code_for_pred_mul_scalar (<CODE>, <MODE>mode), + riscv_vector::TERNARY_OP_FRM_DYN, ops); + DONE; + } + [(set_attr "type" "vfmuladd")] +) + +(define_insn_and_split "*<optab>_vf_<mode>" + [(set (match_operand:V_VLSF 0 "register_operand" "=vd") + (plus_minus:V_VLSF + (match_operand:V_VLSF 3 "register_operand" " vr") + (mult:V_VLSF + (vec_duplicate:V_VLSF + (match_operand:<VEL> 1 "register_operand" " f")) + (match_operand:V_VLSF 2 "register_operand" " 0"))))] + "TARGET_VECTOR && can_create_pseudo_p ()" + "#" + "&& 1" + [(const_int 0)] + { + rtx ops[] = {operands[0], operands[1], operands[2], operands[3], + operands[2]}; + riscv_vector::emit_vlmax_insn (code_for_pred_mul_scalar (<CODE>, <MODE>mode), + riscv_vector::TERNARY_OP_FRM_DYN, ops); + DONE; + } + [(set_attr "type" "vfmuladd")] +) diff --git a/gcc/config/riscv/riscv-cores.def b/gcc/config/riscv/riscv-cores.def index 118fef2..cff7c77 100644 --- a/gcc/config/riscv/riscv-cores.def +++ b/gcc/config/riscv/riscv-cores.def @@ -48,6 +48,7 @@ RISCV_TUNE("xt-c910v2", generic, generic_ooo_tune_info) RISCV_TUNE("xt-c920", generic, generic_ooo_tune_info) RISCV_TUNE("xt-c920v2", generic, generic_ooo_tune_info) RISCV_TUNE("xiangshan-nanhu", xiangshan, xiangshan_nanhu_tune_info) +RISCV_TUNE("xiangshan-kunminghu", xiangshan, generic_ooo_tune_info) RISCV_TUNE("generic-ooo", generic_ooo, generic_ooo_tune_info) RISCV_TUNE("size", generic, optimize_size_tune_info) RISCV_TUNE("mips-p8700", mips_p8700, mips_p8700_tune_info) @@ -154,6 +155,19 @@ RISCV_CORE("xiangshan-nanhu", "rv64imafdc_zba_zbb_zbc_zbs_" "svinval_zicbom_zicboz", "xiangshan-nanhu") +RISCV_CORE("xiangshan-kunminghu", "rv64imafdcbvh_sdtrig_sha_shcounterenw_" + "shgatpa_shlcofideleg_shtvala_shvsatpa_shvstvala_shvstvecd_" + "smaia_smcsrind_smdbltrp_smmpm_smnpm_smrnmi_smstateen_" + "ssaia_ssccptr_sscofpmf_sscounterenw_sscsrind_ssdbltrp_" + "ssnpm_sspm_ssstateen_ssstrict_sstc_sstvala_sstvecd_" + "ssu64xl_supm_svade_svbare_svinval_svnapot_svpbmt_za64rs_" + "zacas_zawrs_zba_zbb_zbc_zbkb_zbkc_zbkx_zbs_zcb_zcmop_" + "zfa_zfh_zfhmin_zic64b_zicbom_zicbop_zicboz_ziccif_" + "zicclsm_ziccrse_zicntr_zicond_zicsr_zifencei_zihintpause_" + "zihpm_zimop_zkn_zknd_zkne_zknh_zksed_zksh_zkt_zvbb_zvfh_" + "zvfhmin_zvkt_zvl128b_zvl32b_zvl64b", + "xiangshan-kunminghu") + RISCV_CORE("mips-p8700", "rv64imafd_zicsr_zmmul_" "zaamo_zalrsc_zba_zbb", "mips-p8700") diff --git a/gcc/config/riscv/riscv-ext.def b/gcc/config/riscv/riscv-ext.def index d0adc2b..816acaa 100644 --- a/gcc/config/riscv/riscv-ext.def +++ b/gcc/config/riscv/riscv-ext.def @@ -73,7 +73,7 @@ Format of DEFINE_RISCV_EXT: DEFINE_RISCV_EXT( /* NAME */ e, - /* UPPERCAE_NAME */ RVE, + /* UPPERCASE_NAME */ RVE, /* FULL_NAME */ "Reduced base integer extension", /* DESC */ "", /* URL */ , @@ -86,7 +86,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ i, - /* UPPERCAE_NAME */ RVI, + /* UPPERCASE_NAME */ RVI, /* FULL_NAME */ "Base integer extension", /* DESC */ "", /* URL */ , @@ -101,7 +101,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ m, - /* UPPERCAE_NAME */ MUL, + /* UPPERCASE_NAME */ MUL, /* FULL_NAME */ "Integer multiplication and division extension", /* DESC */ "", /* URL */ , @@ -114,7 +114,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ a, - /* UPPERCAE_NAME */ ATOMIC, + /* UPPERCASE_NAME */ ATOMIC, /* FULL_NAME */ "Atomic extension", /* DESC */ "", /* URL */ , @@ -129,7 +129,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ f, - /* UPPERCAE_NAME */ HARD_FLOAT, + /* UPPERCASE_NAME */ HARD_FLOAT, /* FULL_NAME */ "Single-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -144,7 +144,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ d, - /* UPPERCAE_NAME */ DOUBLE_FLOAT, + /* UPPERCASE_NAME */ DOUBLE_FLOAT, /* FULL_NAME */ "Double-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -159,7 +159,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ c, - /* UPPERCAE_NAME */ RVC, + /* UPPERCASE_NAME */ RVC, /* FULL_NAME */ "Compressed extension", /* DESC */ "", /* URL */ , @@ -183,7 +183,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ b, - /* UPPERCAE_NAME */ RVB, + /* UPPERCASE_NAME */ RVB, /* FULL_NAME */ "b extension", /* DESC */ "", /* URL */ , @@ -196,7 +196,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ v, - /* UPPERCAE_NAME */ RVV, + /* UPPERCASE_NAME */ RVV, /* FULL_NAME */ "Vector extension", /* DESC */ "", /* URL */ , @@ -209,7 +209,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ h, - /* UPPERCAE_NAME */ RVH, + /* UPPERCASE_NAME */ RVH, /* FULL_NAME */ "Hypervisor extension", /* DESC */ "", /* URL */ , @@ -222,7 +222,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zic64b, - /* UPPERCAE_NAME */ ZIC64B, + /* UPPERCASE_NAME */ ZIC64B, /* FULL_NAME */ "Cache block size isf 64 bytes", /* DESC */ "", /* URL */ , @@ -235,7 +235,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicbom, - /* UPPERCAE_NAME */ ZICBOM, + /* UPPERCASE_NAME */ ZICBOM, /* FULL_NAME */ "Cache-block management extension", /* DESC */ "", /* URL */ , @@ -248,7 +248,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicbop, - /* UPPERCAE_NAME */ ZICBOP, + /* UPPERCASE_NAME */ ZICBOP, /* FULL_NAME */ "Cache-block prefetch extension", /* DESC */ "", /* URL */ , @@ -261,7 +261,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicboz, - /* UPPERCAE_NAME */ ZICBOZ, + /* UPPERCASE_NAME */ ZICBOZ, /* FULL_NAME */ "Cache-block zero extension", /* DESC */ "", /* URL */ , @@ -274,7 +274,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ziccamoa, - /* UPPERCAE_NAME */ ZICCAMOA, + /* UPPERCASE_NAME */ ZICCAMOA, /* FULL_NAME */ "Main memory supports all atomics in A", /* DESC */ "", /* URL */ , @@ -287,7 +287,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ziccif, - /* UPPERCAE_NAME */ ZICCIF, + /* UPPERCASE_NAME */ ZICCIF, /* FULL_NAME */ "Main memory supports instruction fetch with atomicity requirement", /* DESC */ "", /* URL */ , @@ -300,7 +300,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicclsm, - /* UPPERCAE_NAME */ ZICCLSM, + /* UPPERCASE_NAME */ ZICCLSM, /* FULL_NAME */ "Main memory supports misaligned loads/stores", /* DESC */ "", /* URL */ , @@ -313,7 +313,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ziccrse, - /* UPPERCAE_NAME */ ZICCRSE, + /* UPPERCASE_NAME */ ZICCRSE, /* FULL_NAME */ "Main memory supports forward progress on LR/SC sequences", /* DESC */ "", /* URL */ , @@ -326,7 +326,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicfilp, - /* UPPERCAE_NAME */ ZICFILP, + /* UPPERCASE_NAME */ ZICFILP, /* FULL_NAME */ "zicfilp extension", /* DESC */ "", /* URL */ , @@ -339,7 +339,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicfiss, - /* UPPERCAE_NAME */ ZICFISS, + /* UPPERCASE_NAME */ ZICFISS, /* FULL_NAME */ "zicfiss extension", /* DESC */ "", /* URL */ , @@ -352,7 +352,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicntr, - /* UPPERCAE_NAME */ ZICNTR, + /* UPPERCASE_NAME */ ZICNTR, /* FULL_NAME */ "Standard extension for base counters and timers", /* DESC */ "", /* URL */ , @@ -365,7 +365,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicond, - /* UPPERCAE_NAME */ ZICOND, + /* UPPERCASE_NAME */ ZICOND, /* FULL_NAME */ "Integer conditional operations extension", /* DESC */ "", /* URL */ , @@ -378,7 +378,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicsr, - /* UPPERCAE_NAME */ ZICSR, + /* UPPERCASE_NAME */ ZICSR, /* FULL_NAME */ "Control and status register access extension", /* DESC */ "", /* URL */ , @@ -391,7 +391,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zifencei, - /* UPPERCAE_NAME */ ZIFENCEI, + /* UPPERCASE_NAME */ ZIFENCEI, /* FULL_NAME */ "Instruction-fetch fence extension", /* DESC */ "", /* URL */ , @@ -404,7 +404,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zihintntl, - /* UPPERCAE_NAME */ ZIHINTNTL, + /* UPPERCASE_NAME */ ZIHINTNTL, /* FULL_NAME */ "Non-temporal locality hints extension", /* DESC */ "", /* URL */ , @@ -417,7 +417,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zihintpause, - /* UPPERCAE_NAME */ ZIHINTPAUSE, + /* UPPERCASE_NAME */ ZIHINTPAUSE, /* FULL_NAME */ "Pause hint extension", /* DESC */ "", /* URL */ , @@ -430,7 +430,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zihpm, - /* UPPERCAE_NAME */ ZIHPM, + /* UPPERCASE_NAME */ ZIHPM, /* FULL_NAME */ "Standard extension for hardware performance counters", /* DESC */ "", /* URL */ , @@ -443,7 +443,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zimop, - /* UPPERCAE_NAME */ ZIMOP, + /* UPPERCASE_NAME */ ZIMOP, /* FULL_NAME */ "zimop extension", /* DESC */ "", /* URL */ , @@ -456,7 +456,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zilsd, - /* UPPERCAE_NAME */ ZILSD, + /* UPPERCASE_NAME */ ZILSD, /* FULL_NAME */ "Load/Store pair instructions extension", /* DESC */ "", /* URL */ , @@ -469,7 +469,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zmmul, - /* UPPERCAE_NAME */ ZMMUL, + /* UPPERCASE_NAME */ ZMMUL, /* FULL_NAME */ "Integer multiplication extension", /* DESC */ "", /* URL */ , @@ -482,7 +482,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ za128rs, - /* UPPERCAE_NAME */ ZA128RS, + /* UPPERCASE_NAME */ ZA128RS, /* FULL_NAME */ "Reservation set size of 128 bytes", /* DESC */ "", /* URL */ , @@ -495,7 +495,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ za64rs, - /* UPPERCAE_NAME */ ZA64RS, + /* UPPERCASE_NAME */ ZA64RS, /* FULL_NAME */ "Reservation set size of 64 bytes", /* DESC */ "", /* URL */ , @@ -508,7 +508,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zaamo, - /* UPPERCAE_NAME */ ZAAMO, + /* UPPERCASE_NAME */ ZAAMO, /* FULL_NAME */ "zaamo extension", /* DESC */ "", /* URL */ , @@ -521,7 +521,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zabha, - /* UPPERCAE_NAME */ ZABHA, + /* UPPERCASE_NAME */ ZABHA, /* FULL_NAME */ "zabha extension", /* DESC */ "", /* URL */ , @@ -534,7 +534,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zacas, - /* UPPERCAE_NAME */ ZACAS, + /* UPPERCASE_NAME */ ZACAS, /* FULL_NAME */ "zacas extension", /* DESC */ "", /* URL */ , @@ -547,7 +547,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zalrsc, - /* UPPERCAE_NAME */ ZALRSC, + /* UPPERCASE_NAME */ ZALRSC, /* FULL_NAME */ "zalrsc extension", /* DESC */ "", /* URL */ , @@ -560,7 +560,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zawrs, - /* UPPERCAE_NAME */ ZAWRS, + /* UPPERCASE_NAME */ ZAWRS, /* FULL_NAME */ "Wait-on-reservation-set extension", /* DESC */ "", /* URL */ , @@ -573,7 +573,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zama16b, - /* UPPERCAE_NAME */ ZAMA16B, + /* UPPERCASE_NAME */ ZAMA16B, /* FULL_NAME */ "Zama16b extension", /* DESC */ "Misaligned loads, stores, and AMOs to main memory regions that do" " not cross a naturally aligned 16-byte boundary are atomic.", @@ -587,7 +587,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfa, - /* UPPERCAE_NAME */ ZFA, + /* UPPERCASE_NAME */ ZFA, /* FULL_NAME */ "Additional floating-point extension", /* DESC */ "", /* URL */ , @@ -600,7 +600,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfbfmin, - /* UPPERCAE_NAME */ ZFBFMIN, + /* UPPERCASE_NAME */ ZFBFMIN, /* FULL_NAME */ "zfbfmin extension", /* DESC */ "", /* URL */ , @@ -613,7 +613,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfh, - /* UPPERCAE_NAME */ ZFH, + /* UPPERCASE_NAME */ ZFH, /* FULL_NAME */ "Half-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -626,7 +626,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfhmin, - /* UPPERCAE_NAME */ ZFHMIN, + /* UPPERCASE_NAME */ ZFHMIN, /* FULL_NAME */ "Minimal half-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -639,7 +639,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfinx, - /* UPPERCAE_NAME */ ZFINX, + /* UPPERCASE_NAME */ ZFINX, /* FULL_NAME */ "Single-precision floating-point in integer registers extension", /* DESC */ "", /* URL */ , @@ -652,7 +652,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zdinx, - /* UPPERCAE_NAME */ ZDINX, + /* UPPERCASE_NAME */ ZDINX, /* FULL_NAME */ "Double-precision floating-point in integer registers extension", /* DESC */ "", /* URL */ , @@ -665,7 +665,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zca, - /* UPPERCAE_NAME */ ZCA, + /* UPPERCASE_NAME */ ZCA, /* FULL_NAME */ "Integer compressed instruction extension", /* DESC */ "", /* URL */ , @@ -709,7 +709,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcb, - /* UPPERCAE_NAME */ ZCB, + /* UPPERCASE_NAME */ ZCB, /* FULL_NAME */ "Simple compressed instruction extension", /* DESC */ "", /* URL */ , @@ -722,7 +722,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcd, - /* UPPERCAE_NAME */ ZCD, + /* UPPERCASE_NAME */ ZCD, /* FULL_NAME */ "Compressed double-precision floating point loads and stores extension", /* DESC */ "", /* URL */ , @@ -735,7 +735,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zce, - /* UPPERCAE_NAME */ ZCE, + /* UPPERCASE_NAME */ ZCE, /* FULL_NAME */ "Compressed instruction extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -754,7 +754,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcf, - /* UPPERCAE_NAME */ ZCF, + /* UPPERCASE_NAME */ ZCF, /* FULL_NAME */ "Compressed single-precision floating point loads and stores extension", /* DESC */ "", /* URL */ , @@ -767,7 +767,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcmop, - /* UPPERCAE_NAME */ ZCMOP, + /* UPPERCASE_NAME */ ZCMOP, /* FULL_NAME */ "zcmop extension", /* DESC */ "", /* URL */ , @@ -780,7 +780,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcmp, - /* UPPERCAE_NAME */ ZCMP, + /* UPPERCASE_NAME */ ZCMP, /* FULL_NAME */ "Compressed push pop extension", /* DESC */ "", /* URL */ , @@ -793,7 +793,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcmt, - /* UPPERCAE_NAME */ ZCMT, + /* UPPERCASE_NAME */ ZCMT, /* FULL_NAME */ "Table jump instruction extension", /* DESC */ "", /* URL */ , @@ -806,7 +806,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zclsd, - /* UPPERCAE_NAME */ ZCLSD, + /* UPPERCASE_NAME */ ZCLSD, /* FULL_NAME */ "Compressed load/store pair instructions extension", /* DESC */ "", /* URL */ , @@ -819,7 +819,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zba, - /* UPPERCAE_NAME */ ZBA, + /* UPPERCASE_NAME */ ZBA, /* FULL_NAME */ "Address calculation extension", /* DESC */ "", /* URL */ , @@ -832,7 +832,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbb, - /* UPPERCAE_NAME */ ZBB, + /* UPPERCASE_NAME */ ZBB, /* FULL_NAME */ "Basic bit manipulation extension", /* DESC */ "", /* URL */ , @@ -845,7 +845,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbc, - /* UPPERCAE_NAME */ ZBC, + /* UPPERCASE_NAME */ ZBC, /* FULL_NAME */ "Carry-less multiplication extension", /* DESC */ "", /* URL */ , @@ -858,7 +858,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbkb, - /* UPPERCAE_NAME */ ZBKB, + /* UPPERCASE_NAME */ ZBKB, /* FULL_NAME */ "Cryptography bit-manipulation extension", /* DESC */ "", /* URL */ , @@ -871,7 +871,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbkc, - /* UPPERCAE_NAME */ ZBKC, + /* UPPERCASE_NAME */ ZBKC, /* FULL_NAME */ "Cryptography carry-less multiply extension", /* DESC */ "", /* URL */ , @@ -884,7 +884,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbkx, - /* UPPERCAE_NAME */ ZBKX, + /* UPPERCASE_NAME */ ZBKX, /* FULL_NAME */ "Cryptography crossbar permutation extension", /* DESC */ "", /* URL */ , @@ -897,7 +897,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbs, - /* UPPERCAE_NAME */ ZBS, + /* UPPERCASE_NAME */ ZBS, /* FULL_NAME */ "Single-bit operation extension", /* DESC */ "", /* URL */ , @@ -910,7 +910,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zk, - /* UPPERCAE_NAME */ ZK, + /* UPPERCASE_NAME */ ZK, /* FULL_NAME */ "Standard scalar cryptography extension", /* DESC */ "", /* URL */ , @@ -923,7 +923,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zkn, - /* UPPERCAE_NAME */ ZKN, + /* UPPERCASE_NAME */ ZKN, /* FULL_NAME */ "NIST algorithm suite extension", /* DESC */ "", /* URL */ , @@ -936,7 +936,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zknd, - /* UPPERCAE_NAME */ ZKND, + /* UPPERCASE_NAME */ ZKND, /* FULL_NAME */ "AES Decryption extension", /* DESC */ "", /* URL */ , @@ -949,7 +949,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zkne, - /* UPPERCAE_NAME */ ZKNE, + /* UPPERCASE_NAME */ ZKNE, /* FULL_NAME */ "AES Encryption extension", /* DESC */ "", /* URL */ , @@ -962,7 +962,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zknh, - /* UPPERCAE_NAME */ ZKNH, + /* UPPERCASE_NAME */ ZKNH, /* FULL_NAME */ "Hash function extension", /* DESC */ "", /* URL */ , @@ -975,7 +975,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zkr, - /* UPPERCAE_NAME */ ZKR, + /* UPPERCASE_NAME */ ZKR, /* FULL_NAME */ "Entropy source extension", /* DESC */ "", /* URL */ , @@ -988,7 +988,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zks, - /* UPPERCAE_NAME */ ZKS, + /* UPPERCASE_NAME */ ZKS, /* FULL_NAME */ "ShangMi algorithm suite extension", /* DESC */ "", /* URL */ , @@ -1001,7 +1001,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zksed, - /* UPPERCAE_NAME */ ZKSED, + /* UPPERCASE_NAME */ ZKSED, /* FULL_NAME */ "SM4 block cipher extension", /* DESC */ "", /* URL */ , @@ -1014,7 +1014,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zksh, - /* UPPERCAE_NAME */ ZKSH, + /* UPPERCASE_NAME */ ZKSH, /* FULL_NAME */ "SM3 hash function extension", /* DESC */ "", /* URL */ , @@ -1027,7 +1027,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zkt, - /* UPPERCAE_NAME */ ZKT, + /* UPPERCASE_NAME */ ZKT, /* FULL_NAME */ "Data independent execution latency extension", /* DESC */ "", /* URL */ , @@ -1040,7 +1040,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ztso, - /* UPPERCAE_NAME */ ZTSO, + /* UPPERCASE_NAME */ ZTSO, /* FULL_NAME */ "Total store ordering extension", /* DESC */ "", /* URL */ , @@ -1053,7 +1053,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvbb, - /* UPPERCAE_NAME */ ZVBB, + /* UPPERCASE_NAME */ ZVBB, /* FULL_NAME */ "Vector basic bit-manipulation extension", /* DESC */ "", /* URL */ , @@ -1066,7 +1066,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvbc, - /* UPPERCAE_NAME */ ZVBC, + /* UPPERCASE_NAME */ ZVBC, /* FULL_NAME */ "Vector carryless multiplication extension", /* DESC */ "", /* URL */ , @@ -1079,7 +1079,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve32f, - /* UPPERCAE_NAME */ ZVE32F, + /* UPPERCASE_NAME */ ZVE32F, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1092,7 +1092,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve32x, - /* UPPERCAE_NAME */ ZVE32X, + /* UPPERCASE_NAME */ ZVE32X, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1105,7 +1105,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve64d, - /* UPPERCAE_NAME */ ZVE64D, + /* UPPERCASE_NAME */ ZVE64D, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1118,7 +1118,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve64f, - /* UPPERCAE_NAME */ ZVE64F, + /* UPPERCASE_NAME */ ZVE64F, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1131,7 +1131,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve64x, - /* UPPERCAE_NAME */ ZVE64X, + /* UPPERCASE_NAME */ ZVE64X, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1144,7 +1144,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvfbfmin, - /* UPPERCAE_NAME */ ZVFBFMIN, + /* UPPERCASE_NAME */ ZVFBFMIN, /* FULL_NAME */ "Vector BF16 converts extension", /* DESC */ "", /* URL */ , @@ -1157,7 +1157,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvfbfwma, - /* UPPERCAE_NAME */ ZVFBFWMA, + /* UPPERCASE_NAME */ ZVFBFWMA, /* FULL_NAME */ "zvfbfwma extension", /* DESC */ "", /* URL */ , @@ -1170,7 +1170,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvfh, - /* UPPERCAE_NAME */ ZVFH, + /* UPPERCASE_NAME */ ZVFH, /* FULL_NAME */ "Vector half-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -1183,7 +1183,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvfhmin, - /* UPPERCAE_NAME */ ZVFHMIN, + /* UPPERCASE_NAME */ ZVFHMIN, /* FULL_NAME */ "Vector minimal half-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -1196,7 +1196,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkb, - /* UPPERCAE_NAME */ ZVKB, + /* UPPERCASE_NAME */ ZVKB, /* FULL_NAME */ "Vector cryptography bit-manipulation extension", /* DESC */ "", /* URL */ , @@ -1209,7 +1209,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkg, - /* UPPERCAE_NAME */ ZVKG, + /* UPPERCASE_NAME */ ZVKG, /* FULL_NAME */ "Vector GCM/GMAC extension", /* DESC */ "", /* URL */ , @@ -1222,7 +1222,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkn, - /* UPPERCAE_NAME */ ZVKN, + /* UPPERCASE_NAME */ ZVKN, /* FULL_NAME */ "Vector NIST Algorithm Suite extension", /* DESC */ "@samp{zvkn} will expand to", /* URL */ , @@ -1235,7 +1235,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvknc, - /* UPPERCAE_NAME */ ZVKNC, + /* UPPERCASE_NAME */ ZVKNC, /* FULL_NAME */ "Vector NIST Algorithm Suite with carryless multiply extension, @samp{zvknc}", /* DESC */ "", /* URL */ , @@ -1248,7 +1248,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkned, - /* UPPERCAE_NAME */ ZVKNED, + /* UPPERCASE_NAME */ ZVKNED, /* FULL_NAME */ "Vector AES block cipher extension", /* DESC */ "", /* URL */ , @@ -1261,7 +1261,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkng, - /* UPPERCAE_NAME */ ZVKNG, + /* UPPERCASE_NAME */ ZVKNG, /* FULL_NAME */ "Vector NIST Algorithm Suite with GCM extension, @samp{zvkng} will expand", /* DESC */ "", /* URL */ , @@ -1274,7 +1274,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvknha, - /* UPPERCAE_NAME */ ZVKNHA, + /* UPPERCASE_NAME */ ZVKNHA, /* FULL_NAME */ "Vector SHA-2 secure hash extension", /* DESC */ "", /* URL */ , @@ -1287,7 +1287,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvknhb, - /* UPPERCAE_NAME */ ZVKNHB, + /* UPPERCASE_NAME */ ZVKNHB, /* FULL_NAME */ "Vector SHA-2 secure hash extension", /* DESC */ "", /* URL */ , @@ -1300,7 +1300,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvks, - /* UPPERCAE_NAME */ ZVKS, + /* UPPERCASE_NAME */ ZVKS, /* FULL_NAME */ "Vector ShangMi algorithm suite extension, @samp{zvks} will expand", /* DESC */ "", /* URL */ , @@ -1313,7 +1313,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvksc, - /* UPPERCAE_NAME */ ZVKSC, + /* UPPERCASE_NAME */ ZVKSC, /* FULL_NAME */ "Vector ShangMi algorithm suite with carryless multiplication extension,", /* DESC */ "", /* URL */ , @@ -1326,7 +1326,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvksed, - /* UPPERCAE_NAME */ ZVKSED, + /* UPPERCASE_NAME */ ZVKSED, /* FULL_NAME */ "Vector SM4 Block Cipher extension", /* DESC */ "", /* URL */ , @@ -1339,7 +1339,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvksg, - /* UPPERCAE_NAME */ ZVKSG, + /* UPPERCASE_NAME */ ZVKSG, /* FULL_NAME */ "Vector ShangMi algorithm suite with GCM extension, @samp{zvksg} will expand", /* DESC */ "", /* URL */ , @@ -1352,7 +1352,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvksh, - /* UPPERCAE_NAME */ ZVKSH, + /* UPPERCASE_NAME */ ZVKSH, /* FULL_NAME */ "Vector SM3 Secure Hash extension", /* DESC */ "", /* URL */ , @@ -1365,7 +1365,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkt, - /* UPPERCAE_NAME */ ZVKT, + /* UPPERCASE_NAME */ ZVKT, /* FULL_NAME */ "Vector data independent execution latency extension", /* DESC */ "", /* URL */ , @@ -1378,7 +1378,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl1024b, - /* UPPERCAE_NAME */ ZVL1024B, + /* UPPERCASE_NAME */ ZVL1024B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1391,7 +1391,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl128b, - /* UPPERCAE_NAME */ ZVL128B, + /* UPPERCASE_NAME */ ZVL128B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1404,7 +1404,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl16384b, - /* UPPERCAE_NAME */ ZVL16384B, + /* UPPERCASE_NAME */ ZVL16384B, /* FULL_NAME */ "zvl16384b extension", /* DESC */ "", /* URL */ , @@ -1417,7 +1417,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl2048b, - /* UPPERCAE_NAME */ ZVL2048B, + /* UPPERCASE_NAME */ ZVL2048B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1430,7 +1430,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl256b, - /* UPPERCAE_NAME */ ZVL256B, + /* UPPERCASE_NAME */ ZVL256B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1443,7 +1443,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl32768b, - /* UPPERCAE_NAME */ ZVL32768B, + /* UPPERCASE_NAME */ ZVL32768B, /* FULL_NAME */ "zvl32768b extension", /* DESC */ "", /* URL */ , @@ -1456,7 +1456,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl32b, - /* UPPERCAE_NAME */ ZVL32B, + /* UPPERCASE_NAME */ ZVL32B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1469,7 +1469,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl4096b, - /* UPPERCAE_NAME */ ZVL4096B, + /* UPPERCASE_NAME */ ZVL4096B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1482,7 +1482,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl512b, - /* UPPERCAE_NAME */ ZVL512B, + /* UPPERCASE_NAME */ ZVL512B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1495,7 +1495,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl64b, - /* UPPERCAE_NAME */ ZVL64B, + /* UPPERCASE_NAME */ ZVL64B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1508,7 +1508,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl65536b, - /* UPPERCAE_NAME */ ZVL65536B, + /* UPPERCASE_NAME */ ZVL65536B, /* FULL_NAME */ "zvl65536b extension", /* DESC */ "", /* URL */ , @@ -1521,7 +1521,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl8192b, - /* UPPERCAE_NAME */ ZVL8192B, + /* UPPERCASE_NAME */ ZVL8192B, /* FULL_NAME */ "zvl8192b extension", /* DESC */ "", /* URL */ , @@ -1534,7 +1534,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zhinx, - /* UPPERCAE_NAME */ ZHINX, + /* UPPERCASE_NAME */ ZHINX, /* FULL_NAME */ "Half-precision floating-point in integer registers extension", /* DESC */ "", /* URL */ , @@ -1547,7 +1547,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zhinxmin, - /* UPPERCAE_NAME */ ZHINXMIN, + /* UPPERCASE_NAME */ ZHINXMIN, /* FULL_NAME */ "Minimal half-precision floating-point in integer registers extension", /* DESC */ "", /* URL */ , @@ -1560,7 +1560,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ sdtrig, - /* UPPERCAE_NAME */ SDTRIG, + /* UPPERCASE_NAME */ SDTRIG, /* FULL_NAME */ "sdtrig extension", /* DESC */ "", /* URL */ , @@ -1573,7 +1573,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ sha, - /* UPPERCAE_NAME */ SHA, + /* UPPERCASE_NAME */ SHA, /* FULL_NAME */ "The augmented hypervisor extension", /* DESC */ "", /* URL */ , @@ -1586,7 +1586,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shcounterenw, - /* UPPERCAE_NAME */ SHCOUNTERENW, + /* UPPERCASE_NAME */ SHCOUNTERENW, /* FULL_NAME */ "Support writeable enables for any supported counter", /* DESC */ "", /* URL */ , @@ -1599,7 +1599,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shgatpa, - /* UPPERCAE_NAME */ SHGATPA, + /* UPPERCASE_NAME */ SHGATPA, /* FULL_NAME */ "SvNNx4 mode supported for all modes supported by satp", /* DESC */ "", /* URL */ , @@ -1611,8 +1611,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ shlcofideleg, + /* UPPERCASE_NAME */ SHLCOFIDELEG, + /* FULL_NAME */ "Delegating LCOFI interrupts to VS-mode", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"h"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ sh, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ shtvala, - /* UPPERCAE_NAME */ SHTVALA, + /* UPPERCASE_NAME */ SHTVALA, /* FULL_NAME */ "The htval register provides all needed values", /* DESC */ "", /* URL */ , @@ -1625,7 +1638,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shvstvala, - /* UPPERCAE_NAME */ SHVSTVALA, + /* UPPERCASE_NAME */ SHVSTVALA, /* FULL_NAME */ "The vstval register provides all needed values", /* DESC */ "", /* URL */ , @@ -1638,7 +1651,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shvstvecd, - /* UPPERCAE_NAME */ SHVSTVECD, + /* UPPERCASE_NAME */ SHVSTVECD, /* FULL_NAME */ "The vstvec register supports Direct mode", /* DESC */ "", /* URL */ , @@ -1651,7 +1664,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shvsatpa, - /* UPPERCAE_NAME */ SHVSATPA, + /* UPPERCASE_NAME */ SHVSATPA, /* FULL_NAME */ "The vsatp register supports all modes supported by satp", /* DESC */ "", /* URL */ , @@ -1664,7 +1677,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smaia, - /* UPPERCAE_NAME */ SMAIA, + /* UPPERCASE_NAME */ SMAIA, /* FULL_NAME */ "Advanced interrupt architecture extension", /* DESC */ "", /* URL */ , @@ -1677,7 +1690,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smcntrpmf, - /* UPPERCAE_NAME */ SMCNTRPMF, + /* UPPERCASE_NAME */ SMCNTRPMF, /* FULL_NAME */ "Cycle and instret privilege mode filtering", /* DESC */ "", /* URL */ , @@ -1689,8 +1702,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ smcsrind, + /* UPPERCASE_NAME */ SMCSRIND, + /* FULL_NAME */ "Machine-Level Indirect CSR Access", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr", "sscsrind"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ sm, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ smepmp, - /* UPPERCAE_NAME */ SMEPMP, + /* UPPERCASE_NAME */ SMEPMP, /* FULL_NAME */ "PMP Enhancements for memory access and execution prevention on Machine mode", /* DESC */ "", /* URL */ , @@ -1703,7 +1729,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smmpm, - /* UPPERCAE_NAME */ SMMPM, + /* UPPERCASE_NAME */ SMMPM, /* FULL_NAME */ "smmpm extension", /* DESC */ "", /* URL */ , @@ -1716,7 +1742,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smnpm, - /* UPPERCAE_NAME */ SMNPM, + /* UPPERCASE_NAME */ SMNPM, /* FULL_NAME */ "smnpm extension", /* DESC */ "", /* URL */ , @@ -1728,8 +1754,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ smrnmi, + /* UPPERCASE_NAME */ SMRNMI, + /* FULL_NAME */ "Resumable non-maskable interrupts", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ sm, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ smstateen, - /* UPPERCAE_NAME */ SMSTATEEN, + /* UPPERCASE_NAME */ SMSTATEEN, /* FULL_NAME */ "State enable extension", /* DESC */ "", /* URL */ , @@ -1742,7 +1781,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smdbltrp, - /* UPPERCAE_NAME */ SMDBLTRP, + /* UPPERCASE_NAME */ SMDBLTRP, /* FULL_NAME */ "Double Trap Extensions", /* DESC */ "", /* URL */ , @@ -1755,7 +1794,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ssaia, - /* UPPERCAE_NAME */ SSAIA, + /* UPPERCASE_NAME */ SSAIA, /* FULL_NAME */ "Advanced interrupt architecture extension for supervisor-mode", /* DESC */ "", /* URL */ , @@ -1767,8 +1806,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ ssccptr, + /* UPPERCASE_NAME */ SSCCPTR, + /* FULL_NAME */ "Main memory supports page table reads", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ sscofpmf, - /* UPPERCAE_NAME */ SSCOFPMF, + /* UPPERCASE_NAME */ SSCOFPMF, /* FULL_NAME */ "Count overflow & filtering extension", /* DESC */ "", /* URL */ , @@ -1780,8 +1832,34 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ sscounterenw, + /* UPPERCASE_NAME */ SSCOUNTERENW, + /* FULL_NAME */ "Support writeable enables for any supported counter", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( + /* NAME */ sscsrind, + /* UPPERCASE_NAME */ SSCSRIND, + /* FULL_NAME */ "Supervisor-Level Indirect CSR Access", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ ssnpm, - /* UPPERCAE_NAME */ SSNPM, + /* UPPERCASE_NAME */ SSNPM, /* FULL_NAME */ "ssnpm extension", /* DESC */ "", /* URL */ , @@ -1794,7 +1872,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ sspm, - /* UPPERCAE_NAME */ SSPM, + /* UPPERCASE_NAME */ SSPM, /* FULL_NAME */ "sspm extension", /* DESC */ "", /* URL */ , @@ -1807,7 +1885,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ssstateen, - /* UPPERCAE_NAME */ SSSTATEEN, + /* UPPERCASE_NAME */ SSSTATEEN, /* FULL_NAME */ "State-enable extension for supervisor-mode", /* DESC */ "", /* URL */ , @@ -1820,7 +1898,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ sstc, - /* UPPERCAE_NAME */ SSTC, + /* UPPERCASE_NAME */ SSTC, /* FULL_NAME */ "Supervisor-mode timer interrupts extension", /* DESC */ "", /* URL */ , @@ -1832,8 +1910,34 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ sstvala, + /* UPPERCASE_NAME */ SSTVALA, + /* FULL_NAME */ "Stval provides all needed values", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( + /* NAME */ sstvecd, + /* UPPERCASE_NAME */ SSTVECD, + /* FULL_NAME */ "Stvec supports Direct mode", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ ssstrict, - /* UPPERCAE_NAME */ SSSTRICT, + /* UPPERCASE_NAME */ SSSTRICT, /* FULL_NAME */ "ssstrict extension", /* DESC */ "", /* URL */ , @@ -1846,7 +1950,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ssdbltrp, - /* UPPERCAE_NAME */ SSDBLTRP, + /* UPPERCASE_NAME */ SSDBLTRP, /* FULL_NAME */ "Double Trap Extensions", /* DESC */ "", /* URL */ , @@ -1858,8 +1962,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ ssu64xl, + /* UPPERCASE_NAME */ SSU64XL, + /* FULL_NAME */ "UXLEN=64 must be supported", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ supm, - /* UPPERCAE_NAME */ SUPM, + /* UPPERCASE_NAME */ SUPM, /* FULL_NAME */ "supm extension", /* DESC */ "", /* URL */ , @@ -1872,7 +1989,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svinval, - /* UPPERCAE_NAME */ SVINVAL, + /* UPPERCASE_NAME */ SVINVAL, /* FULL_NAME */ "Fine-grained address-translation cache invalidation extension", /* DESC */ "", /* URL */ , @@ -1885,7 +2002,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svnapot, - /* UPPERCAE_NAME */ SVNAPOT, + /* UPPERCASE_NAME */ SVNAPOT, /* FULL_NAME */ "NAPOT translation contiguity extension", /* DESC */ "", /* URL */ , @@ -1898,7 +2015,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svpbmt, - /* UPPERCAE_NAME */ SVPBMT, + /* UPPERCASE_NAME */ SVPBMT, /* FULL_NAME */ "Page-based memory types extension", /* DESC */ "", /* URL */ , @@ -1911,7 +2028,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svvptc, - /* UPPERCAE_NAME */ SVVPTC, + /* UPPERCASE_NAME */ SVVPTC, /* FULL_NAME */ "svvptc extension", /* DESC */ "", /* URL */ , @@ -1924,11 +2041,11 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svadu, - /* UPPERCAE_NAME */ SVADU, + /* UPPERCASE_NAME */ SVADU, /* FULL_NAME */ "Hardware Updating of A/D Bits extension", /* DESC */ "", /* URL */ , - /* DEP_EXTS */ ({}), + /* DEP_EXTS */ ({"zicsr"}), /* SUPPORTED_VERSIONS */ ({{1, 0}}), /* FLAG_GROUP */ sv, /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, @@ -1937,11 +2054,24 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svade, - /* UPPERCAE_NAME */ SVADE, + /* UPPERCASE_NAME */ SVADE, /* FULL_NAME */ "Cause exception when hardware updating of A/D bits is disabled", /* DESC */ "", /* URL */ , - /* DEP_EXTS */ ({}), + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ sv, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( + /* NAME */ svbare, + /* UPPERCASE_NAME */ SVBARE, + /* FULL_NAME */ "Satp mode bare is supported", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), /* SUPPORTED_VERSIONS */ ({{1, 0}}), /* FLAG_GROUP */ sv, /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, diff --git a/gcc/config/riscv/riscv-ext.opt b/gcc/config/riscv/riscv-ext.opt index c0dcde6..9f8c545 100644 --- a/gcc/config/riscv/riscv-ext.opt +++ b/gcc/config/riscv/riscv-ext.opt @@ -325,6 +325,8 @@ Mask(SHCOUNTERENW) Var(riscv_sh_subext) Mask(SHGATPA) Var(riscv_sh_subext) +Mask(SHLCOFIDELEG) Var(riscv_sh_subext) + Mask(SHTVALA) Var(riscv_sh_subext) Mask(SHVSTVALA) Var(riscv_sh_subext) @@ -337,20 +339,30 @@ Mask(SMAIA) Var(riscv_sm_subext) Mask(SMCNTRPMF) Var(riscv_sm_subext) +Mask(SMCSRIND) Var(riscv_sm_subext) + Mask(SMEPMP) Var(riscv_sm_subext) Mask(SMMPM) Var(riscv_sm_subext) Mask(SMNPM) Var(riscv_sm_subext) +Mask(SMRNMI) Var(riscv_sm_subext) + Mask(SMSTATEEN) Var(riscv_sm_subext) Mask(SMDBLTRP) Var(riscv_sm_subext) Mask(SSAIA) Var(riscv_ss_subext) +Mask(SSCCPTR) Var(riscv_ss_subext) + Mask(SSCOFPMF) Var(riscv_ss_subext) +Mask(SSCOUNTERENW) Var(riscv_ss_subext) + +Mask(SSCSRIND) Var(riscv_ss_subext) + Mask(SSNPM) Var(riscv_ss_subext) Mask(SSPM) Var(riscv_ss_subext) @@ -359,10 +371,16 @@ Mask(SSSTATEEN) Var(riscv_ss_subext) Mask(SSTC) Var(riscv_ss_subext) +Mask(SSTVALA) Var(riscv_ss_subext) + +Mask(SSTVECD) Var(riscv_ss_subext) + Mask(SSSTRICT) Var(riscv_ss_subext) Mask(SSDBLTRP) Var(riscv_ss_subext) +Mask(SSU64XL) Var(riscv_ss_subext) + Mask(SUPM) Var(riscv_su_subext) Mask(SVINVAL) Var(riscv_sv_subext) @@ -377,6 +395,8 @@ Mask(SVADU) Var(riscv_sv_subext) Mask(SVADE) Var(riscv_sv_subext) +Mask(SVBARE) Var(riscv_sv_subext) + Mask(XCVALU) Var(riscv_xcv_subext) Mask(XCVBI) Var(riscv_xcv_subext) diff --git a/gcc/config/riscv/riscv-opts.h b/gcc/config/riscv/riscv-opts.h index c02c599..e1a820b 100644 --- a/gcc/config/riscv/riscv-opts.h +++ b/gcc/config/riscv/riscv-opts.h @@ -164,6 +164,7 @@ enum riscv_tls_type { (TARGET_VECTOR && riscv_mautovec_segment) #define GPR2VR_COST_UNPROVIDED -1 +#define FPR2VR_COST_UNPROVIDED -1 /* Extra extension flags, used for carry extra info for a RISC-V extension. */ enum diff --git a/gcc/config/riscv/riscv-protos.h b/gcc/config/riscv/riscv-protos.h index d8c8f6b..a033120 100644 --- a/gcc/config/riscv/riscv-protos.h +++ b/gcc/config/riscv/riscv-protos.h @@ -841,6 +841,7 @@ const struct riscv_tune_info * riscv_parse_tune (const char *, bool); const cpu_vector_cost *get_vector_costs (); int get_gr2vr_cost (); +int get_fr2vr_cost (); enum { diff --git a/gcc/config/riscv/riscv-v.cc b/gcc/config/riscv/riscv-v.cc index 6162797..a41317f 100644 --- a/gcc/config/riscv/riscv-v.cc +++ b/gcc/config/riscv/riscv-v.cc @@ -5567,6 +5567,7 @@ expand_vx_binary_vec_vec_dup (rtx op_0, rtx op_1, rtx op_2, case IOR: case XOR: case MULT: + case DIV: icode = code_for_pred_scalar (code, mode); break; default: diff --git a/gcc/config/riscv/riscv-vector-costs.cc b/gcc/config/riscv/riscv-vector-costs.cc index a39b611..4d8170d 100644 --- a/gcc/config/riscv/riscv-vector-costs.cc +++ b/gcc/config/riscv/riscv-vector-costs.cc @@ -1099,8 +1099,8 @@ costs::adjust_stmt_cost (enum vect_cost_for_stmt kind, loop_vec_info loop, switch (kind) { case scalar_to_vec: - stmt_cost += (FLOAT_TYPE_P (vectype) ? costs->regmove->FR2VR - : get_gr2vr_cost ()); + stmt_cost + += (FLOAT_TYPE_P (vectype) ? get_fr2vr_cost () : get_gr2vr_cost ()); break; case vec_to_scalar: stmt_cost += (FLOAT_TYPE_P (vectype) ? costs->regmove->VR2FR diff --git a/gcc/config/riscv/riscv.cc b/gcc/config/riscv/riscv.cc index d3cee96..413eae0 100644 --- a/gcc/config/riscv/riscv.cc +++ b/gcc/config/riscv/riscv.cc @@ -3891,6 +3891,25 @@ riscv_extend_cost (rtx op, bool unsigned_p) return COSTS_N_INSNS (2); } +/* Return the cost of the vector binary rtx like add, minus, mult. + The cost of scalar2vr_cost will be appended if there one of the + op comes from the VEC_DUPLICATE. */ + +static int +get_vector_binary_rtx_cost (rtx x, int scalar2vr_cost) +{ + gcc_assert (riscv_v_ext_mode_p (GET_MODE (x))); + + rtx op_0 = XEXP (x, 0); + rtx op_1 = XEXP (x, 1); + + if (GET_CODE (op_0) == VEC_DUPLICATE + || GET_CODE (op_1) == VEC_DUPLICATE) + return (scalar2vr_cost + 1) * COSTS_N_INSNS (1); + else + return COSTS_N_INSNS (1); +} + /* Implement TARGET_RTX_COSTS. */ #define SINGLE_SHIFT_COST 1 @@ -3904,6 +3923,9 @@ riscv_rtx_costs (rtx x, machine_mode mode, int outer_code, int opno ATTRIBUTE_UN if (riscv_v_ext_mode_p (mode)) { int gr2vr_cost = get_gr2vr_cost (); + int fr2vr_cost = get_fr2vr_cost (); + int scalar2vr_cost = FLOAT_MODE_P (GET_MODE_INNER (mode)) + ? fr2vr_cost : gr2vr_cost; switch (outer_code) { @@ -3914,6 +3936,21 @@ riscv_rtx_costs (rtx x, machine_mode mode, int outer_code, int opno ATTRIBUTE_UN case VEC_DUPLICATE: *total = gr2vr_cost * COSTS_N_INSNS (1); break; + case IF_THEN_ELSE: + { + rtx op = XEXP (x, 1); + + switch (GET_CODE (op)) + { + case DIV: + *total = get_vector_binary_rtx_cost (op, scalar2vr_cost); + break; + default: + *total = COSTS_N_INSNS (1); + break; + } + } + break; case PLUS: case MINUS: case AND: @@ -3921,14 +3958,15 @@ riscv_rtx_costs (rtx x, machine_mode mode, int outer_code, int opno ATTRIBUTE_UN case XOR: case MULT: { + rtx op; rtx op_0 = XEXP (x, 0); rtx op_1 = XEXP (x, 1); - if (GET_CODE (op_0) == VEC_DUPLICATE - || GET_CODE (op_1) == VEC_DUPLICATE) - *total = (gr2vr_cost + 1) * COSTS_N_INSNS (1); + if (GET_CODE (op = op_0) == MULT + || GET_CODE (op = op_1) == MULT) + *total = get_vector_binary_rtx_cost (op, scalar2vr_cost); else - *total = COSTS_N_INSNS (1); + *total = get_vector_binary_rtx_cost (x, scalar2vr_cost); } break; default: @@ -5355,6 +5393,40 @@ riscv_expand_conditional_move (rtx dest, rtx op, rtx cons, rtx alt) rtx op0 = XEXP (op, 0); rtx op1 = XEXP (op, 1); + /* For some tests, we can easily construct a 0, -1 value + which can then be used to synthesize more efficient + sequences that don't use zicond. */ + if ((code == LT || code == GE) + && (REG_P (op0) || SUBREG_P (op0)) + && op1 == CONST0_RTX (GET_MODE (op0))) + { + /* The code to expand signed division by a power of 2 uses a + conditional add by 2^n-1 idiom. It can be more efficiently + synthesized without zicond using srai+srli+add. + + But we don't see the constants here. Just a conditional move + with registers as the true/false values. So this is a little + over-aggressive and can result in a few missed if-conversions. */ + if ((REG_P (cons) || SUBREG_P (cons)) + && (REG_P (alt) || SUBREG_P (alt))) + return false; + + /* If one value is a nonzero constant and the other value is + not a constant, then avoid zicond as more efficient sequences + using the splatted sign bit are often possible. */ + if (CONST_INT_P (alt) + && alt != CONST0_RTX (mode) + && !CONST_INT_P (cons)) + return false; + + if (CONST_INT_P (cons) + && cons != CONST0_RTX (mode) + && !CONST_INT_P (alt)) + return false; + + /* If we need more special cases, add them here. */ + } + if (((TARGET_ZICOND_LIKE || (arith_operand (cons, mode) && arith_operand (alt, mode))) && (GET_MODE_CLASS (mode) == MODE_INT)) @@ -9781,7 +9853,7 @@ riscv_register_move_cost (machine_mode mode, if (from_is_gpr) return get_gr2vr_cost (); else if (from_is_fpr) - return get_vector_costs ()->regmove->FR2VR; + return get_fr2vr_cost (); } return riscv_secondary_memory_needed (mode, from, to) ? 8 : 2; @@ -12647,6 +12719,21 @@ get_gr2vr_cost () return cost; } +/* Return the cost of moving data from floating-point to vector register. + It will take the value of --param=fpr2vr-cost if it is provided. + Otherwise the default regmove->FR2VR will be returned. */ + +int +get_fr2vr_cost () +{ + int cost = get_vector_costs ()->regmove->FR2VR; + + if (fpr2vr_cost != FPR2VR_COST_UNPROVIDED) + cost = fpr2vr_cost; + + return cost; +} + /* Implement targetm.vectorize.builtin_vectorization_cost. */ static int @@ -12712,8 +12799,7 @@ riscv_builtin_vectorization_cost (enum vect_cost_for_stmt type_of_cost, case vec_construct: { /* TODO: This is too pessimistic in case we can splat. */ - int regmove_cost = fp ? costs->regmove->FR2VR - : get_gr2vr_cost (); + int regmove_cost = fp ? get_fr2vr_cost () : get_gr2vr_cost (); return (regmove_cost + common_costs->scalar_to_vec_cost) * estimated_poly_value (TYPE_VECTOR_SUBPARTS (vectype)); } diff --git a/gcc/config/riscv/riscv.md b/gcc/config/riscv/riscv.md index 92fe7c7..6d3c80a 100644 --- a/gcc/config/riscv/riscv.md +++ b/gcc/config/riscv/riscv.md @@ -4834,6 +4834,24 @@ [(set_attr "type" "move") (set_attr "mode" "<MODE>")]) +;; If we're trying to create 0 or 2^n-1 based on the result of +;; a test such as (lt (reg) (const_int 0)), we'll see a splat of +;; the sign bit across a GPR using srai, then a logical and to +;; mask off high bits. We can replace the logical and with +;; a logical right shift which works without constant synthesis +;; for larger constants. +(define_split + [(set (match_operand:X 0 "register_operand") + (and:X (ashiftrt:X (match_operand:X 1 "register_operand") + (match_operand 2 "const_int_operand")) + (match_operand 3 "const_int_operand")))] + "(INTVAL (operands[2]) == BITS_PER_WORD - 1 + && exact_log2 (INTVAL (operands[3]) + 1) >= 0)" + [(set (match_dup 0) (ashiftrt:X (match_dup 1) (match_dup 2))) + (set (match_dup 0) (lshiftrt:X (match_dup 0) (match_dup 3)))] + { operands[3] = GEN_INT (BITS_PER_WORD + - exact_log2 (INTVAL (operands[3]) + 1)); }) + (include "bitmanip.md") (include "crypto.md") (include "sync.md") diff --git a/gcc/config/riscv/riscv.opt b/gcc/config/riscv/riscv.opt index b2b9d33..6543fd1 100644 --- a/gcc/config/riscv/riscv.opt +++ b/gcc/config/riscv/riscv.opt @@ -286,6 +286,10 @@ Max number of bytes to compare as part of inlined strcmp/strncmp routines (defau Target RejectNegative Joined UInteger Var(gpr2vr_cost) Init(GPR2VR_COST_UNPROVIDED) Set the cost value of the rvv instruction when operate from GPR to VR. +-param=fpr2vr-cost= +Target RejectNegative Joined UInteger Var(fpr2vr_cost) Init(FPR2VR_COST_UNPROVIDED) +Set the cost value of the rvv instruction when operate from FPR to VR. + -param=riscv-autovec-mode= Target Undocumented RejectNegative Joined Var(riscv_autovec_mode) Save Set the only autovec mode to try. diff --git a/gcc/config/riscv/vector-iterators.md b/gcc/config/riscv/vector-iterators.md index 2bd99ee..86f31f3 100644 --- a/gcc/config/riscv/vector-iterators.md +++ b/gcc/config/riscv/vector-iterators.md @@ -4041,7 +4041,11 @@ smax umax smin umin mult div udiv mod umod ]) -(define_code_iterator any_int_binop_no_shift_vx [ +(define_code_iterator any_int_binop_no_shift_v_vdup [ + plus minus and ior xor mult div +]) + +(define_code_iterator any_int_binop_no_shift_vdup_v [ plus minus and ior xor mult ]) diff --git a/gcc/config/riscv/zicond.md b/gcc/config/riscv/zicond.md index f87b4f2..d170f6a 100644 --- a/gcc/config/riscv/zicond.md +++ b/gcc/config/riscv/zicond.md @@ -234,5 +234,39 @@ (const_int 0) (match_dup 4)))]) +;; We can splat the sign bit across a GPR with a arithmetic right shift +;; which gives us a 0, -1 result. We then turn on bit #0 unconditionally +;; which results in 1, -1. There's probably other cases that could be +;; handled, this seems particularly important though. +(define_split + [(set (match_operand:X 0 "register_operand") + (plus:X (if_then_else:X (ge:X (match_operand:X 1 "register_operand") + (const_int 0)) + (match_operand 2 "const_int_operand") + (match_operand 3 "const_int_operand")) + (match_operand 4 "const_int_operand")))] + "((TARGET_ZICOND_LIKE || TARGET_XTHEADCONDMOV) + && INTVAL (operands[2]) + INTVAL (operands[4]) == 1 + && INTVAL (operands[3]) + INTVAL (operands[4]) == -1)" + [(set (match_dup 0) (ashiftrt:X (match_dup 1) (match_dup 2))) + (set (match_dup 0) (ior:X (match_dup 0) (const_int 1)))] + { operands[2] = GEN_INT (GET_MODE_BITSIZE (word_mode) - 1); }) - +;; Similarly, but the condition and true/false values are reversed +;; +;; Note the case where the condition is reversed, but not the true/false +;; values. Or vice-versa is not handled because we don't support 4->3 +;; splits. +(define_split + [(set (match_operand:X 0 "register_operand") + (plus:X (if_then_else:X (lt:X (match_operand:X 1 "register_operand") + (const_int 0)) + (match_operand 2 "const_int_operand") + (match_operand 3 "const_int_operand")) + (match_operand 4 "const_int_operand")))] + "((TARGET_ZICOND_LIKE || TARGET_XTHEADCONDMOV) + && INTVAL (operands[2]) + INTVAL (operands[4]) == -1 + && INTVAL (operands[3]) + INTVAL (operands[4]) == 1)" + [(set (match_dup 0) (ashiftrt:X (match_dup 1) (match_dup 2))) + (set (match_dup 0) (ior:X (match_dup 0) (const_int 1)))] + { operands[2] = GEN_INT (GET_MODE_BITSIZE (word_mode) - 1); }) diff --git a/gcc/coverage.cc b/gcc/coverage.cc index 7181e75..c0ae76a4 100644 --- a/gcc/coverage.cc +++ b/gcc/coverage.cc @@ -1253,6 +1253,9 @@ coverage_obj_finish (vec<constructor_elt, va_gc> *ctor, void coverage_init (const char *filename) { + /* If we are in LTO, the profile will be read from object files. */ + if (in_lto_p) + return; const char *original_filename = filename; int original_len = strlen (original_filename); #if HAVE_DOS_BASED_FILE_SYSTEM diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index a8f2b4e..0541c5d 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,48 @@ +2025-06-05 Patrick Palka <ppalka@redhat.com> + + PR c++/120224 + * pt.cc (tsubst_function_decl): Return error_mark_node if + substituting into the formal parameter list failed. + (tsubst_decl) <case PARM_DECL>: Return error_mark_node + upon TREE_TYPE substitution failure, when in a SFINAE + context. Return error_mark_node upon DECL_CHAIN substitution + failure. + +2025-06-05 Patrick Palka <ppalka@redhat.com> + + PR c++/118340 + * constexpr.cc (maybe_constant_value): First try looking up each + operand in the cv_cache and reusing the result. + +2025-06-05 Iain Sandoe <iain@sandoe.co.uk> + + * coroutines.cc (analyze_fn_parms): Move from free function.. + (cp_coroutine_transform::analyze_fn_parms):... to method. + (cp_coroutine_transform::apply_transforms): Adjust call to + analyze_fn_parms. + * coroutines.h: Declare analyze_fn_parms. + +2025-06-05 Iain Sandoe <iain@sandoe.co.uk> + + * coroutines.cc (expand_one_await_expression): Set the + initial_await_resume_called flag here. + (build_actor_fn): Populate the frame accessor for the + initial_await_resume_called flag. + (cp_coroutine_transform::wrap_original_function_body): Do + not modify the initial_await expression to include the + initial_await_resume_called flag here. + +2025-06-04 Jason Merrill <jason@redhat.com> + + PR c++/120502 + * cp-gimplify.cc (cp_fold_r) [TARGET_EXPR]: Do constexpr evaluation + before genericize. + * constexpr.cc (cxx_eval_store_expression): Add comment. + +2025-06-03 Jason Merrill <jason@redhat.com> + + * name-lookup.h (operator|, operator|=): Define for WMB_Flags. + 2025-06-02 Jason Merrill <jason@redhat.com> PR c++/107600 diff --git a/gcc/cp/constexpr.cc b/gcc/cp/constexpr.cc index b9fdc94..7078839 100644 --- a/gcc/cp/constexpr.cc +++ b/gcc/cp/constexpr.cc @@ -6413,7 +6413,8 @@ cxx_eval_store_expression (const constexpr_ctx *ctx, tree t, if (TREE_CLOBBER_P (init) && CLOBBER_KIND (init) < CLOBBER_OBJECT_END) - /* Only handle clobbers ending the lifetime of objects. */ + /* Only handle clobbers ending the lifetime of objects. + ??? We should probably set CONSTRUCTOR_NO_CLEARING. */ return void_node; /* First we figure out where we're storing to. */ @@ -9487,8 +9488,35 @@ tree maybe_constant_value (tree t, tree decl /* = NULL_TREE */, mce_value manifestly_const_eval /* = mce_unknown */) { + tree orig_t = t; tree r; + if (EXPR_P (t) && manifestly_const_eval == mce_unknown) + { + /* Look up each operand in the cv_cache first to see if we've already + reduced it, and reuse that result to avoid quadratic behavior if + we're called when building up a large expression. */ + int n = cp_tree_operand_length (t); + tree *ops = XALLOCAVEC (tree, n); + bool rebuild = false; + for (int i = 0; i < n; ++i) + { + ops[i] = TREE_OPERAND (t, i); + if (tree *cached = hash_map_safe_get (cv_cache, ops[i])) + if (*cached != ops[i]) + { + ops[i] = *cached; + rebuild = true; + } + } + if (rebuild) + { + t = copy_node (t); + for (int i = 0; i < n; ++i) + TREE_OPERAND (t, i) = ops[i]; + } + } + if (!is_nondependent_constant_expression (t)) { if (TREE_OVERFLOW_P (t) @@ -9506,6 +9534,10 @@ maybe_constant_value (tree t, tree decl /* = NULL_TREE */, return fold_to_constant (t); if (manifestly_const_eval != mce_unknown) + /* TODO: Extend the cache to be mce_value aware. And if we have a + previously cached mce_unknown result that's TREE_CONSTANT, it means + the reduced value is independent of mce_value and so we should + be able to reuse it in the mce_true/false case. */ return cxx_eval_outermost_constant_expr (t, true, true, manifestly_const_eval, false, decl); @@ -9535,7 +9567,7 @@ maybe_constant_value (tree t, tree decl /* = NULL_TREE */, || (TREE_CONSTANT (t) && !TREE_CONSTANT (r)) || !cp_tree_equal (r, t)); if (!c.evaluation_restricted_p ()) - cv_cache->put (t, r); + cv_cache->put (orig_t, r); return r; } diff --git a/gcc/cp/coroutines.cc b/gcc/cp/coroutines.cc index 7f5d30c..97eee6e 100644 --- a/gcc/cp/coroutines.cc +++ b/gcc/cp/coroutines.cc @@ -2027,8 +2027,10 @@ expand_one_await_expression (tree *expr, tree *await_expr, void *d) tree awaiter_calls = TREE_OPERAND (saved_co_await, 3); tree source = TREE_OPERAND (saved_co_await, 4); - bool is_final = (source - && TREE_INT_CST_LOW (source) == (int) FINAL_SUSPEND_POINT); + bool is_final + = (source && TREE_INT_CST_LOW (source) == (int) FINAL_SUSPEND_POINT); + bool is_initial + = (source && TREE_INT_CST_LOW (source) == (int) INITIAL_SUSPEND_POINT); /* Build labels for the destinations of the control flow when we are resuming or destroying. */ @@ -2156,6 +2158,13 @@ expand_one_await_expression (tree *expr, tree *await_expr, void *d) /* Resume point. */ add_stmt (build_stmt (loc, LABEL_EXPR, resume_label)); + if (is_initial && data->i_a_r_c) + { + r = cp_build_modify_expr (loc, data->i_a_r_c, NOP_EXPR, boolean_true_node, + tf_warning_or_error); + finish_expr_stmt (r); + } + /* This will produce the value (if one is provided) from the co_await expression. */ tree resume_call = TREE_VEC_ELT (awaiter_calls, 2); /* await_resume(). */ @@ -2654,8 +2663,12 @@ build_actor_fn (location_t loc, tree coro_frame_type, tree actor, tree fnbody, /* We've now rewritten the tree and added the initial and final co_awaits. Now pass over the tree and expand the co_awaits. */ + tree i_a_r_c = NULL_TREE; + if (flag_exceptions) + i_a_r_c = coro_build_frame_access_expr (actor_frame, coro_frame_i_a_r_c_id, + false, tf_warning_or_error); - coro_aw_data data = {actor, actor_fp, resume_idx_var, NULL_TREE, + coro_aw_data data = {actor, actor_fp, resume_idx_var, i_a_r_c, ash, del_promise_label, ret_label, continue_label, restart_dispatch_label, continuation, 2}; cp_walk_tree (&actor_body, await_statement_expander, &data, NULL); @@ -4014,12 +4027,14 @@ rewrite_param_uses (tree *stmt, int *do_subtree ATTRIBUTE_UNUSED, void *d) } /* Build up a set of info that determines how each param copy will be - handled. */ + handled. We store this in a hash map so that we can access it from + a tree walk callback that re-writes the original parameters to their + copies. */ -static void -analyze_fn_parms (tree orig, hash_map<tree, param_info> *param_uses) +void +cp_coroutine_transform::analyze_fn_parms () { - if (!DECL_ARGUMENTS (orig)) + if (!DECL_ARGUMENTS (orig_fn_decl)) return; /* Build a hash map with an entry for each param. @@ -4029,19 +4044,19 @@ analyze_fn_parms (tree orig, hash_map<tree, param_info> *param_uses) Then a tree list of the uses. The second two entries start out empty - and only get populated when we see uses. */ - bool lambda_p = LAMBDA_FUNCTION_P (orig); + bool lambda_p = LAMBDA_FUNCTION_P (orig_fn_decl); /* Count the param copies from 1 as per the std. */ unsigned parm_num = 1; - for (tree arg = DECL_ARGUMENTS (orig); arg != NULL; + for (tree arg = DECL_ARGUMENTS (orig_fn_decl); arg != NULL; ++parm_num, arg = DECL_CHAIN (arg)) { bool existed; - param_info &parm = param_uses->get_or_insert (arg, &existed); + param_info &parm = param_uses.get_or_insert (arg, &existed); gcc_checking_assert (!existed); parm.body_uses = NULL; tree actual_type = TREE_TYPE (arg); - actual_type = complete_type_or_else (actual_type, orig); + actual_type = complete_type_or_else (actual_type, orig_fn_decl); if (actual_type == NULL_TREE) actual_type = error_mark_node; parm.orig_type = actual_type; @@ -4435,30 +4450,6 @@ cp_coroutine_transform::wrap_original_function_body () tree tcb = build_stmt (loc, TRY_BLOCK, NULL_TREE, NULL_TREE); add_stmt (tcb); TRY_STMTS (tcb) = push_stmt_list (); - if (initial_await != error_mark_node) - { - /* Build a compound expression that sets the - initial-await-resume-called variable true and then calls the - initial suspend expression await resume. - In the case that the user decides to make the initial await - await_resume() return a value, we need to discard it and, it is - a reference type, look past the indirection. */ - if (INDIRECT_REF_P (initial_await)) - initial_await = TREE_OPERAND (initial_await, 0); - /* In the case that the initial_await returns a target expression - we might need to look through that to update the await expr. */ - tree iaw = initial_await; - if (TREE_CODE (iaw) == TARGET_EXPR) - iaw = TARGET_EXPR_INITIAL (iaw); - gcc_checking_assert (TREE_CODE (iaw) == CO_AWAIT_EXPR); - tree vec = TREE_OPERAND (iaw, 3); - tree aw_r = TREE_VEC_ELT (vec, 2); - aw_r = convert_to_void (aw_r, ICV_STATEMENT, tf_warning_or_error); - tree update = build2 (MODIFY_EXPR, boolean_type_node, i_a_r_c, - boolean_true_node); - aw_r = cp_build_compound_expr (update, aw_r, tf_warning_or_error); - TREE_VEC_ELT (vec, 2) = aw_r; - } /* Add the initial await to the start of the user-authored function. */ finish_expr_stmt (initial_await); /* Append the original function body. */ @@ -5260,7 +5251,7 @@ cp_coroutine_transform::apply_transforms () /* Collect information on the original function params and their use in the function body. */ - analyze_fn_parms (orig_fn_decl, ¶m_uses); + analyze_fn_parms (); /* Declare the actor and destroyer functions, the following code needs to see these. */ diff --git a/gcc/cp/coroutines.h b/gcc/cp/coroutines.h index 10698cf..55caa6e 100644 --- a/gcc/cp/coroutines.h +++ b/gcc/cp/coroutines.h @@ -126,6 +126,7 @@ private: bool inline_p = false; bool valid_coroutine = false; + void analyze_fn_parms (); void wrap_original_function_body (); bool build_ramp_function (); }; diff --git a/gcc/cp/cp-gimplify.cc b/gcc/cp/cp-gimplify.cc index 16def88..0fcfa16 100644 --- a/gcc/cp/cp-gimplify.cc +++ b/gcc/cp/cp-gimplify.cc @@ -1473,6 +1473,19 @@ cp_fold_r (tree *stmt_p, int *walk_subtrees, void *data_) break; case TARGET_EXPR: + if (!flag_no_inline) + if (tree &init = TARGET_EXPR_INITIAL (stmt)) + { + tree folded = maybe_constant_init (init, TARGET_EXPR_SLOT (stmt), + (data->flags & ff_mce_false + ? mce_false : mce_unknown)); + if (folded != init && TREE_CONSTANT (folded)) + init = folded; + } + + /* This needs to happen between the constexpr evaluation (which wants + pre-generic trees) and fold (which wants the cp_genericize_init + transformations). */ if (data->flags & ff_genericize) cp_genericize_target_expr (stmt_p); @@ -1481,14 +1494,6 @@ cp_fold_r (tree *stmt_p, int *walk_subtrees, void *data_) cp_walk_tree (&init, cp_fold_r, data, NULL); cp_walk_tree (&TARGET_EXPR_CLEANUP (stmt), cp_fold_r, data, NULL); *walk_subtrees = 0; - if (!flag_no_inline) - { - tree folded = maybe_constant_init (init, TARGET_EXPR_SLOT (stmt), - (data->flags & ff_mce_false - ? mce_false : mce_unknown)); - if (folded != init && TREE_CONSTANT (folded)) - init = folded; - } /* Folding might replace e.g. a COND_EXPR with a TARGET_EXPR; in that case, strip it in favor of this one. */ if (TREE_CODE (init) == TARGET_EXPR) diff --git a/gcc/cp/name-lookup.h b/gcc/cp/name-lookup.h index 4216a51..2fa736b 100644 --- a/gcc/cp/name-lookup.h +++ b/gcc/cp/name-lookup.h @@ -501,6 +501,10 @@ enum WMB_Flags WMB_Hidden = 1 << 3, WMB_Purview = 1 << 4, }; +inline WMB_Flags operator|(WMB_Flags x, WMB_Flags y) +{ return WMB_Flags(+x|y); } +inline WMB_Flags& operator|=(WMB_Flags& x, WMB_Flags y) +{ return x = x|y; } extern unsigned walk_module_binding (tree binding, bitmap partitions, bool (*)(tree decl, WMB_Flags, void *data), diff --git a/gcc/cp/pt.cc b/gcc/cp/pt.cc index c5a3abe..b5c877a 100644 --- a/gcc/cp/pt.cc +++ b/gcc/cp/pt.cc @@ -14983,6 +14983,8 @@ tsubst_function_decl (tree t, tree args, tsubst_flags_t complain, if (closure && DECL_IOBJ_MEMBER_FUNCTION_P (t)) parms = DECL_CHAIN (parms); parms = tsubst (parms, args, complain, t); + if (parms == error_mark_node) + return error_mark_node; for (tree parm = parms; parm; parm = DECL_CHAIN (parm)) DECL_CONTEXT (parm) = r; if (closure && DECL_IOBJ_MEMBER_FUNCTION_P (t)) @@ -15555,6 +15557,9 @@ tsubst_decl (tree t, tree args, tsubst_flags_t complain, /* We're dealing with a normal parameter. */ type = tsubst (TREE_TYPE (t), args, complain, in_decl); + if (type == error_mark_node && !(complain & tf_error)) + RETURN (error_mark_node); + type = type_decays_to (type); TREE_TYPE (r) = type; cp_apply_type_quals_to_decl (cp_type_quals (type), r); @@ -15592,8 +15597,13 @@ tsubst_decl (tree t, tree args, tsubst_flags_t complain, /* If cp_unevaluated_operand is set, we're just looking for a single dummy parameter, so don't keep going. */ if (DECL_CHAIN (t) && !cp_unevaluated_operand) - DECL_CHAIN (r) = tsubst (DECL_CHAIN (t), args, - complain, DECL_CHAIN (t)); + { + tree chain = tsubst (DECL_CHAIN (t), args, + complain, DECL_CHAIN (t)); + if (chain == error_mark_node) + RETURN (error_mark_node); + DECL_CHAIN (r) = chain; + } /* FIRST_R contains the start of the chain we've built. */ r = first_r; diff --git a/gcc/doc/install.texi b/gcc/doc/install.texi index ff08336..fb921b3 100644 --- a/gcc/doc/install.texi +++ b/gcc/doc/install.texi @@ -1342,9 +1342,13 @@ default set of libraries is selected based on the value of @item amdgcn*-*-* @var{list} is a comma separated list of ISA names (allowed values: -@code{gfx900}, @code{gfx906}, @code{gfx908}, @code{gfx90a}, @code{gfx90c}, -@code{gfx1030}, @code{gfx1036}, @code{gfx1100}, @code{gfx1103}). -It ought not include the name of the default +@code{gfx900}, @code{gfx902}, @code{gfx904}, @code{gfx906}, @code{gfx908}, +@code{gfx909}, @code{gfx90a}, @code{gfx90c}, @code{gfx9-generic}, +@code{gfx1030}, @code{gfx1031}, @code{gfx1032}, @code{gfx1033}, +@code{gfx1034}, @code{gfx1035}, @code{gfx1036}, @code{gfx10-3-generic}, +@code{gfx1100}, @code{gfx1101}, @code{gfx1102}, @code{gfx1103}, +@code{gfx1150}, @code{gfx1151}, @code{gfx1152}, @code{gfx1153}, +@code{gfx11-generic}). It ought not include the name of the default ISA, specified via @option{--with-arch}. If @var{list} is empty, then there will be no multilibs and only the default run-time library will be built. If @var{list} is @code{default} or @option{--with-multilib-list=} is not diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index 8de0085..d7f51b4 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -2440,8 +2440,8 @@ ISO C99. This standard is substantially completely supported, modulo bugs and floating-point issues (mainly but not entirely relating to optional C99 features from Annexes F and G). See -@w{@uref{https://gcc.gnu.org/c99status.html}} for more information. The -names @samp{c9x} and @samp{iso9899:199x} are deprecated. +@w{@uref{https://gcc.gnu.org/projects/c-status.html}} for more information. +The names @samp{c9x} and @samp{iso9899:199x} are deprecated. @item c11 @itemx c1x @@ -31200,8 +31200,8 @@ Permissible values for this option are: @samp{mips-p8700}, @samp{sifive-e20}, @samp{sifive-e76}, @samp{sifive-s21}, @samp{sifive-s51}, @samp{sifive-s54}, @samp{sifive-s76}, @samp{sifive-u54}, @samp{sifive-u74}, @samp{sifive-x280}, @samp{sifive-xp450}, @samp{sifive-x670}, @samp{thead-c906}, @samp{tt-ascalon-d8}, -@samp{xiangshan-nanhu}, @samp{xt-c908}, @samp{xt-c908v}, @samp{xt-c910}, @samp{xt-c910v2}, -@samp{xt-c920}, @samp{xt-c920v2}. +@samp{xiangshan-nanhu}, @samp{xiangshan-kunminghu}, @samp{xt-c908}, @samp{xt-c908v}, +@samp{xt-c910}, @samp{xt-c910v2}, @samp{xt-c920}, @samp{xt-c920v2}. Note that @option{-mcpu} does not override @option{-march} or @option{-mtune}. diff --git a/gcc/doc/riscv-ext.texi b/gcc/doc/riscv-ext.texi index e64c0d6..e69a2df 100644 --- a/gcc/doc/riscv-ext.texi +++ b/gcc/doc/riscv-ext.texi @@ -474,6 +474,10 @@ @tab 1.0 @tab SvNNx4 mode supported for all modes supported by satp +@item shlcofideleg +@tab 1.0 +@tab Delegating LCOFI interrupts to VS-mode + @item shtvala @tab 1.0 @tab The htval register provides all needed values @@ -498,6 +502,10 @@ @tab 1.0 @tab Cycle and instret privilege mode filtering +@item smcsrind +@tab 1.0 +@tab Machine-Level Indirect CSR Access + @item smepmp @tab 1.0 @tab PMP Enhancements for memory access and execution prevention on Machine mode @@ -510,6 +518,10 @@ @tab 1.0 @tab smnpm extension +@item smrnmi +@tab 1.0 +@tab Resumable Non-Maskable Interrupts + @item smstateen @tab 1.0 @tab State enable extension @@ -522,10 +534,22 @@ @tab 1.0 @tab Advanced interrupt architecture extension for supervisor-mode +@item ssccptr +@tab 1.0 +@tab Main memory supports page table reads + @item sscofpmf @tab 1.0 @tab Count overflow & filtering extension +@item sscounterenw +@tab 1.0 +@tab Support writeable enables for any supported counter + +@item sscsrind +@tab 1.0 +@tab Supervisor-Level Indirect CSR Access + @item ssnpm @tab 1.0 @tab ssnpm extension @@ -542,6 +566,14 @@ @tab 1.0 @tab Supervisor-mode timer interrupts extension +@item sstvala +@tab 1.0 +@tab Stval provides all needed values + +@item sstvecd +@tab 1.0 +@tab Stvec supports Direct mode + @item ssstrict @tab 1.0 @tab ssstrict extension @@ -550,6 +582,10 @@ @tab 1.0 @tab Double Trap Extensions +@item ssu64xl +@tab 1.0 +@tab UXLEN=64 must be supported + @item supm @tab 1.0 @tab supm extension @@ -578,6 +614,10 @@ @tab 1.0 @tab Cause exception when hardware updating of A/D bits is disabled +@item svbare +@tab 1.0 +@tab Satp mode bare is supported + @item xcvalu @tab 1.0 @tab Core-V miscellaneous ALU extension diff --git a/gcc/doc/standards.texi b/gcc/doc/standards.texi index 011f7e2..0d765b1 100644 --- a/gcc/doc/standards.texi +++ b/gcc/doc/standards.texi @@ -96,8 +96,8 @@ A new edition of the ISO C standard was published in 1999 as ISO/IEC development, drafts of this standard version were referred to as @dfn{C9X}.) GCC has substantially complete support for this standard version; see -@uref{https://gcc.gnu.org/c99status.html} for details. To select this -standard, use @option{-std=c99} or @option{-std=iso9899:1999}. +@uref{https://gcc.gnu.org/projects/c-status.html} for details. To select +this standard, use @option{-std=c99} or @option{-std=iso9899:1999}. Errors in the 1999 ISO C standard were corrected in three Technical Corrigenda published in 2001, 2004 and 2007. GCC does not support the diff --git a/gcc/emit-rtl.cc b/gcc/emit-rtl.cc index 3f453cd..50e3bfc 100644 --- a/gcc/emit-rtl.cc +++ b/gcc/emit-rtl.cc @@ -998,10 +998,11 @@ validate_subreg (machine_mode omode, machine_mode imode, && known_le (osize, isize)) return false; - /* The outer size must be ordered wrt the register size, otherwise - we wouldn't know at compile time how many registers the outer - mode occupies. */ - if (!ordered_p (osize, regsize)) + /* If ISIZE is greater than REGSIZE, the inner value is split into blocks + of size REGSIZE. The outer size must then be ordered wrt REGSIZE, + otherwise we wouldn't know at compile time how many blocks the + outer mode occupies. */ + if (maybe_gt (isize, regsize) && !ordered_p (osize, regsize)) return false; /* For normal pseudo registers, we want most of the same checks. Namely: diff --git a/gcc/expr.cc b/gcc/expr.cc index 1eeefa1..b3b46a2 100644 --- a/gcc/expr.cc +++ b/gcc/expr.cc @@ -7631,8 +7631,8 @@ store_constructor (tree exp, rtx target, int cleared, poly_int64 size, tree domain; tree elttype = TREE_TYPE (type); bool const_bounds_p; - HOST_WIDE_INT minelt = 0; - HOST_WIDE_INT maxelt = 0; + unsigned HOST_WIDE_INT minelt = 0; + unsigned HOST_WIDE_INT maxelt = 0; /* The storage order is specified for every aggregate type. */ reverse = TYPE_REVERSE_STORAGE_ORDER (type); @@ -7640,14 +7640,14 @@ store_constructor (tree exp, rtx target, int cleared, poly_int64 size, domain = TYPE_DOMAIN (type); const_bounds_p = (TYPE_MIN_VALUE (domain) && TYPE_MAX_VALUE (domain) - && tree_fits_shwi_p (TYPE_MIN_VALUE (domain)) - && tree_fits_shwi_p (TYPE_MAX_VALUE (domain))); + && tree_fits_uhwi_p (TYPE_MIN_VALUE (domain)) + && tree_fits_uhwi_p (TYPE_MAX_VALUE (domain))); /* If we have constant bounds for the range of the type, get them. */ if (const_bounds_p) { - minelt = tree_to_shwi (TYPE_MIN_VALUE (domain)); - maxelt = tree_to_shwi (TYPE_MAX_VALUE (domain)); + minelt = tree_to_uhwi (TYPE_MIN_VALUE (domain)); + maxelt = tree_to_uhwi (TYPE_MAX_VALUE (domain)); } /* If the constructor has fewer elements than the array, clear @@ -7660,7 +7660,7 @@ store_constructor (tree exp, rtx target, int cleared, poly_int64 size, else { unsigned HOST_WIDE_INT idx; - HOST_WIDE_INT count = 0, zero_count = 0; + unsigned HOST_WIDE_INT count = 0, zero_count = 0; need_to_clear = ! const_bounds_p; /* This loop is a more accurate version of the loop in @@ -7668,7 +7668,7 @@ store_constructor (tree exp, rtx target, int cleared, poly_int64 size, is also needed to check for missing elements. */ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (exp), idx, index, value) { - HOST_WIDE_INT this_node_count; + unsigned HOST_WIDE_INT this_node_count; if (need_to_clear) break; @@ -7742,16 +7742,16 @@ store_constructor (tree exp, rtx target, int cleared, poly_int64 size, { tree lo_index = TREE_OPERAND (index, 0); tree hi_index = TREE_OPERAND (index, 1); - rtx index_r, pos_rtx; - HOST_WIDE_INT lo, hi, count; - tree position; + rtx index_r; + unsigned HOST_WIDE_INT lo, hi, count; + tree offset; /* If the range is constant and "small", unroll the loop. */ if (const_bounds_p - && tree_fits_shwi_p (lo_index) - && tree_fits_shwi_p (hi_index) - && (lo = tree_to_shwi (lo_index), - hi = tree_to_shwi (hi_index), + && tree_fits_uhwi_p (lo_index) + && tree_fits_uhwi_p (hi_index) + && (lo = tree_to_uhwi (lo_index), + hi = tree_to_uhwi (hi_index), count = hi - lo + 1, (!MEM_P (target) || count <= 2 @@ -7762,7 +7762,7 @@ store_constructor (tree exp, rtx target, int cleared, poly_int64 size, lo -= minelt; hi -= minelt; for (; lo <= hi; lo++) { - bitpos = lo * tree_to_shwi (TYPE_SIZE (elttype)); + bitpos = lo * tree_to_uhwi (TYPE_SIZE (elttype)); if (MEM_P (target) && !MEM_KEEP_ALIAS_SET_P (target) @@ -7798,21 +7798,18 @@ store_constructor (tree exp, rtx target, int cleared, poly_int64 size, emit_label (loop_start); /* Assign value to element index. */ - position = - fold_convert (ssizetype, - fold_build2 (MINUS_EXPR, - TREE_TYPE (index), - index, - TYPE_MIN_VALUE (domain))); - - position = - size_binop (MULT_EXPR, position, - fold_convert (ssizetype, - TYPE_SIZE_UNIT (elttype))); - - pos_rtx = expand_normal (position); - xtarget = offset_address (target, pos_rtx, - highest_pow2_factor (position)); + offset = fold_build2 (MINUS_EXPR, + TREE_TYPE (index), + index, + TYPE_MIN_VALUE (domain)); + + offset = size_binop (MULT_EXPR, + fold_convert (sizetype, offset), + TYPE_SIZE_UNIT (elttype)); + + xtarget = offset_address (target, + expand_normal (offset), + highest_pow2_factor (offset)); xtarget = adjust_address (xtarget, mode, 0); if (TREE_CODE (value) == CONSTRUCTOR) store_constructor (value, xtarget, cleared, @@ -7840,35 +7837,32 @@ store_constructor (tree exp, rtx target, int cleared, poly_int64 size, emit_label (loop_end); } } - else if ((index != 0 && ! tree_fits_shwi_p (index)) - || ! tree_fits_uhwi_p (TYPE_SIZE (elttype))) + else if ((index && !tree_fits_uhwi_p (index)) + || !tree_fits_uhwi_p (TYPE_SIZE (elttype))) { - tree position; - - if (index == 0) - index = ssize_int (1); - - if (minelt) - index = fold_convert (ssizetype, - fold_build2 (MINUS_EXPR, - TREE_TYPE (index), - index, - TYPE_MIN_VALUE (domain))); - - position = - size_binop (MULT_EXPR, index, - fold_convert (ssizetype, - TYPE_SIZE_UNIT (elttype))); + tree offset; + + if (index) + offset = fold_build2 (MINUS_EXPR, + TREE_TYPE (index), + index, + TYPE_MIN_VALUE (domain)); + else + offset = size_int (i); + + offset = size_binop (MULT_EXPR, + fold_convert (sizetype, offset), + TYPE_SIZE_UNIT (elttype)); xtarget = offset_address (target, - expand_normal (position), - highest_pow2_factor (position)); + expand_normal (offset), + highest_pow2_factor (offset)); xtarget = adjust_address (xtarget, mode, 0); store_expr (value, xtarget, 0, false, reverse); } else { - if (index != 0) - bitpos = ((tree_to_shwi (index) - minelt) + if (index) + bitpos = ((tree_to_uhwi (index) - minelt) * tree_to_uhwi (TYPE_SIZE (elttype))); else bitpos = (i * tree_to_uhwi (TYPE_SIZE (elttype))); diff --git a/gcc/ext-dce.cc b/gcc/ext-dce.cc index a034395..aa80c04 100644 --- a/gcc/ext-dce.cc +++ b/gcc/ext-dce.cc @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "print-rtl.h" #include "dbgcnt.h" #include "diagnostic-core.h" +#include "target.h" /* These should probably move into a C++ class. */ static vec<bitmap_head> livein; @@ -764,13 +765,25 @@ ext_dce_process_uses (rtx_insn *insn, rtx obj, We don't want to mark those bits live unnecessarily as that inhibits extension elimination in important cases such as those in Coremark. So we need that - outer code. */ + outer code. + + But if !TRULY_NOOP_TRUNCATION_MODES_P, the mode + change performed by Y would normally need to be a + TRUNCATE rather than a SUBREG. It is probably the + guarantee provided by SUBREG_PROMOTED_VAR_P that + allows the SUBREG in Y as an exception. We must + therefore preserve that guarantee and treat the + upper bits of the inner register as live + regardless of the outer code. See PR 120050. */ if (!REG_P (SUBREG_REG (y)) || (SUBREG_PROMOTED_VAR_P (y) && ((GET_CODE (SET_SRC (x)) == SIGN_EXTEND && SUBREG_PROMOTED_SIGNED_P (y)) || (GET_CODE (SET_SRC (x)) == ZERO_EXTEND - && SUBREG_PROMOTED_UNSIGNED_P (y))))) + && SUBREG_PROMOTED_UNSIGNED_P (y)) + || !TRULY_NOOP_TRUNCATION_MODES_P ( + GET_MODE (y), + GET_MODE (SUBREG_REG (y)))))) break; bit = subreg_lsb (y).to_constant (); diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e740ecc..78f6002 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2025-06-04 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120483 + * trans-expr.cc (gfc_conv_substring): Use pointer arithmetic on + static allocatable char arrays. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99838 + * data.cc (gfc_assign_data_value): For a new initializer use the + location from the constructor as fallback. + 2025-05-30 Harald Anlauf <anlauf@gmx.de> PR fortran/102599 diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc index 5c83f69..a438c26 100644 --- a/gcc/fortran/data.cc +++ b/gcc/fortran/data.cc @@ -593,7 +593,13 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, { /* Point the container at the new expression. */ if (last_con == NULL) - symbol->value = expr; + { + symbol->value = expr; + /* For a new initializer use the location from the + constructor as fallback. */ + if (!GFC_LOCUS_IS_SET(expr->where) && con != NULL) + symbol->value->where = con->where; + } else last_con->expr = expr; } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 8d9448e..74d4265 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2782,9 +2782,11 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, start.expr = gfc_evaluate_now (start.expr, &se->pre); /* Change the start of the string. */ - if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE - || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) - && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE + || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) + && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + || (POINTER_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE)) tmp = se->expr; else tmp = build_fold_indirect_ref_loc (input_location, @@ -2795,6 +2797,14 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); se->expr = gfc_build_addr_expr (type, tmp); } + else if (POINTER_TYPE_P (TREE_TYPE (tmp))) + { + tree diff; + diff = fold_build2 (MINUS_EXPR, size_type_node, start.expr, + build_one_cst (size_type_node)); + se->expr + = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff); + } } /* Length = end + 1 - start. */ diff --git a/gcc/gimple-fold.cc b/gcc/gimple-fold.cc index 0f43761..185f9db 100644 --- a/gcc/gimple-fold.cc +++ b/gcc/gimple-fold.cc @@ -198,10 +198,7 @@ can_refer_decl_in_current_unit_p (tree decl, tree from_decl) tree create_tmp_reg_or_ssa_name (tree type, gimple *stmt) { - if (gimple_in_ssa_p (cfun)) - return make_ssa_name (type, stmt); - else - return create_tmp_reg (type); + return make_ssa_name (type, stmt); } /* CVAL is value taken from DECL_INITIAL of variable. Try to transform it into diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod index 3c29fdd..b5455d0 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -11299,6 +11299,35 @@ END CheckReturnType ; (* + BuildReturnLower - check the return type and value to ensure type + compatibility and no range overflow will occur. +*) + +PROCEDURE BuildReturnLower (tokcombined, tokexpr: CARDINAL; e1, t1: CARDINAL) ; +VAR + e2, t2: CARDINAL ; +BEGIN + (* This will check that the type returned is compatible with + the formal return type of the procedure. *) + CheckReturnType (tokcombined, CurrentProc, e1, t1) ; + (* Dereference LeftValue if necessary. *) + IF GetMode (e1) = LeftValue + THEN + t2 := GetSType (CurrentProc) ; + e2 := MakeTemporary (tokexpr, RightValue) ; + PutVar(e2, t2) ; + CheckPointerThroughNil (tokexpr, e1) ; + doIndrX (tokexpr, e2, e1) ; + e1 := e2 + END ; + (* Here we check the data contents to ensure no overflow. *) + BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ; + GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE, + tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) +END BuildReturnLower ; + + +(* BuildReturn - Builds the Return part of the procedure. tokreturn is the location of the RETURN keyword. The Stack is expected to contain: @@ -11317,7 +11346,6 @@ PROCEDURE BuildReturn (tokreturn: CARDINAL) ; VAR tokcombined, tokexpr : CARDINAL ; - e2, t2, e1, t1, t, f, Des : CARDINAL ; @@ -11337,26 +11365,18 @@ BEGIN tokcombined := MakeVirtualTok (tokreturn, tokreturn, tokexpr) ; IF e1 # NulSym THEN - (* this will check that the type returned is compatible with - the formal return type of the procedure. *) - CheckReturnType (tokcombined, CurrentProc, e1, t1) ; - (* dereference LeftValue if necessary *) - IF GetMode (e1) = LeftValue - THEN - t2 := GetSType (CurrentProc) ; - e2 := MakeTemporary (tokexpr, RightValue) ; - PutVar(e2, t2) ; - CheckPointerThroughNil (tokexpr, e1) ; - doIndrX (tokexpr, e2, e1) ; - (* here we check the data contents to ensure no overflow. *) - BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e2)) ; - GenQuadOtok (tokcombined, ReturnValueOp, e2, NulSym, CurrentProc, FALSE, - tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) + (* Check we are in a procedure scope and that the procedure has a return type. *) + IF CurrentProc = NulSym + THEN + MetaErrorT0 (tokcombined, + '{%1E} attempting to return a value when not in a procedure scope') + ELSIF GetSType (CurrentProc) = NulSym + THEN + MetaErrorT1 (tokcombined, + 'attempting to return a value from procedure {%1Ea} which does not have a return type', + CurrentProc) ELSE - (* here we check the data contents to ensure no overflow. *) - BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ; - GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE, - tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) + BuildReturnLower (tokcombined, tokexpr, e1, t1) END END ; GenQuadO (tokcombined, GotoOp, NulSym, NulSym, PopWord (ReturnStack), FALSE) ; diff --git a/gcc/match.pd b/gcc/match.pd index bde9bd6..0f53c16 100644 --- a/gcc/match.pd +++ b/gcc/match.pd @@ -2177,6 +2177,18 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) (view_convert (rshift (view_convert:ntype @0) @1)) (convert (rshift (convert:ntype @0) @1)))))) +#if GIMPLE + /* Fold ((x + y) >> 1 into IFN_AVG_FLOOR (x, y) if x and y are vectors in + which each element is known to have at least one leading zero bit. */ +(simplify + (rshift (plus:cs @0 @1) integer_onep) + (if (VECTOR_TYPE_P (type) + && direct_internal_fn_supported_p (IFN_AVG_FLOOR, type, OPTIMIZE_FOR_BOTH) + && wi::clz (get_nonzero_bits (@0)) > 0 + && wi::clz (get_nonzero_bits (@1)) > 0) + (IFN_AVG_FLOOR @0 @1))) +#endif + /* Try to fold (type) X op CST -> (type) (X op ((type-x) CST)) when profitable. For bitwise binary operations apply operand conversions to the @@ -11327,7 +11339,7 @@ and, (vec_perm @2 @5 { op0; }))))))))))) -/* Match count trailing zeroes for simplify_count_trailing_zeroes in fwprop. +/* Match count trailing zeroes for simplify_count_zeroes in forwprop. The canonical form is array[((x & -x) * C) >> SHIFT] where C is a magic constant which when multiplied by a power of 2 contains a unique value in the top 5 or 6 bits. This is then indexed into a table which maps it @@ -11335,6 +11347,52 @@ and, (match (ctz_table_index @1 @2 @3) (rshift (mult (bit_and:c (negate @1) @1) INTEGER_CST@2) INTEGER_CST@3)) +/* Match count leading zeros for simplify_count_zeroes in forwprop. + One canonical form is 31 - array[idx] where IDX is computed from X + by first setting all bits from the topmost set bits down via a + series of shifts and ors to X' and then computing (X' * C) >> SHIFT. */ +(match (clz_table_index @1 @2 @3) + (rshift (mult + (bit_ior (rshift + (bit_ior@d (rshift + (bit_ior@c (rshift + (bit_ior@b (rshift + (bit_ior@a (rshift @1 INTEGER_CST@c1) @1) + INTEGER_CST@c2) @a) + INTEGER_CST@c4) @b) + INTEGER_CST@c8) @c) + INTEGER_CST@c16) @d) INTEGER_CST@2) INTEGER_CST@3) + (if (INTEGRAL_TYPE_P (type) + && TYPE_UNSIGNED (type) + && TYPE_PRECISION (type) == 32 + && compare_tree_int (@c1, 1) == 0 + && compare_tree_int (@c2, 2) == 0 + && compare_tree_int (@c4, 4) == 0 + && compare_tree_int (@c8, 8) == 0 + && compare_tree_int (@c16, 16) == 0))) +(match (clz_table_index @1 @2 @3) + (rshift (mult + (bit_ior (rshift + (bit_ior@e (rshift + (bit_ior@d (rshift + (bit_ior@c (rshift + (bit_ior@b (rshift + (bit_ior@a (rshift @1 INTEGER_CST@c1) @1) + INTEGER_CST@c2) @a) + INTEGER_CST@c4) @b) + INTEGER_CST@c8) @c) + INTEGER_CST@c16) @d) + INTEGER_CST@c32) @e) INTEGER_CST@2) INTEGER_CST@3) + (if (INTEGRAL_TYPE_P (type) + && TYPE_UNSIGNED (type) + && TYPE_PRECISION (type) == 64 + && compare_tree_int (@c1, 1) == 0 + && compare_tree_int (@c2, 2) == 0 + && compare_tree_int (@c4, 4) == 0 + && compare_tree_int (@c8, 8) == 0 + && compare_tree_int (@c16, 16) == 0 + && compare_tree_int (@c32, 32) == 0))) + /* Floatint point/integer comparison and integer->integer or floating point -> float point conversion. */ (match (cond_expr_convert_p @0 @2 @3 @6) diff --git a/gcc/omp-general.cc b/gcc/omp-general.cc index 0b7c3b9..c799b89 100644 --- a/gcc/omp-general.cc +++ b/gcc/omp-general.cc @@ -2659,10 +2659,16 @@ omp_selector_is_dynamic (tree ctx) static tree omp_device_num_check (tree *device_num, bool *is_host) { + /* C++ may wrap the device_num expr in a CLEANUP_POINT_EXPR; we want + to look inside of it for the special cases. */ + tree t = *device_num; + if (TREE_CODE (t) == CLEANUP_POINT_EXPR) + t = TREE_OPERAND (t, 0); + /* First check for some constant values we can treat specially. */ - if (tree_fits_shwi_p (*device_num)) + if (tree_fits_shwi_p (t)) { - HOST_WIDE_INT num = tree_to_shwi (*device_num); + HOST_WIDE_INT num = tree_to_shwi (t); if (num < -1) return integer_zero_node; /* Initial device? */ @@ -2681,9 +2687,9 @@ omp_device_num_check (tree *device_num, bool *is_host) /* Also test for direct calls to OpenMP routines that return valid device numbers. */ - if (TREE_CODE (*device_num) == CALL_EXPR) + if (TREE_CODE (t) == CALL_EXPR) { - tree fndecl = get_callee_fndecl (*device_num); + tree fndecl = get_callee_fndecl (t); if (fndecl && omp_runtime_api_call (fndecl)) { const char *fnname = IDENTIFIER_POINTER (DECL_NAME (fndecl)); diff --git a/gcc/pass_manager.h b/gcc/pass_manager.h index d4f8900..4de4a48 100644 --- a/gcc/pass_manager.h +++ b/gcc/pass_manager.h @@ -74,6 +74,7 @@ public: } opt_pass *get_pass_peephole2 () const { return m_pass_peephole2_1; } opt_pass *get_pass_profile () const { return m_pass_profile_1; } + opt_pass *get_pass_auto_profile () const { return m_pass_ipa_auto_profile_1; } void register_pass_name (opt_pass *pass, const char *name); diff --git a/gcc/profile-count.cc b/gcc/profile-count.cc index 2d9c778..22c109a 100644 --- a/gcc/profile-count.cc +++ b/gcc/profile-count.cc @@ -344,6 +344,10 @@ profile_count::to_sreal_scale (profile_count in, bool *known) const return 1; if (!in.m_val) return m_val * 4; + /* Auto-FDO 0 really just means that we have no samples. + Treat it as small non-zero frequency. */ + if (!m_val && quality () == AFDO) + return (sreal)1 / (sreal)in.m_val; return (sreal)m_val / (sreal)in.m_val; } @@ -398,7 +402,7 @@ profile_count::combine_with_ipa_count (profile_count ipa) return this->global0adjusted (); } -/* Sae as profile_count::combine_with_ipa_count but within function with count +/* Same as profile_count::combine_with_ipa_count but within function with count IPA2. */ profile_count profile_count::combine_with_ipa_count_within (profile_count ipa, @@ -410,7 +414,16 @@ profile_count::combine_with_ipa_count_within (profile_count ipa, if (ipa2.ipa () == ipa2 && ipa.initialized_p ()) ret = ipa; else - ret = combine_with_ipa_count (ipa); + { + /* For inconsistent profiles we may end up having ipa2 of GLOBAL0 + while ipa is non-zero (i.e. non-zero IPA counters within function + executed 0 times). Be sure we produce GLOBAL0 as well + so counters remain compatible. */ + if (ipa.nonzero_p () + && ipa2.ipa ().initialized_p ()) + ipa = ipa2.ipa (); + ret = combine_with_ipa_count (ipa); + } gcc_checking_assert (ret.compatible_p (ipa2)); return ret; } diff --git a/gcc/range-op-float.cc b/gcc/range-op-float.cc index dafd9c0..32a6cd7 100644 --- a/gcc/range-op-float.cc +++ b/gcc/range-op-float.cc @@ -51,8 +51,8 @@ along with GCC; see the file COPYING3. If not see bool range_operator::fold_range (frange &r, tree type, - const frange &op1, const frange &op2, - relation_trio trio) const + const frange &op1, const frange &op2, + relation_trio trio) const { if (empty_range_varying (r, type, op1, op2)) return true; @@ -112,20 +112,20 @@ range_operator::rv_fold (frange &r, tree type, bool range_operator::fold_range (irange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const frange &lh ATTRIBUTE_UNUSED, - const irange &rh ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const frange &lh ATTRIBUTE_UNUSED, + const irange &rh ATTRIBUTE_UNUSED, + relation_trio) const { return false; } bool range_operator::fold_range (irange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const frange &lh ATTRIBUTE_UNUSED, - const frange &rh ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const frange &lh ATTRIBUTE_UNUSED, + const frange &rh ATTRIBUTE_UNUSED, + relation_trio) const { return false; } @@ -142,10 +142,10 @@ range_operator::fold_range (frange &r ATTRIBUTE_UNUSED, bool range_operator::op1_range (frange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const frange &lhs ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const frange &lhs ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_trio) const { return false; } @@ -162,56 +162,56 @@ range_operator::op1_range (frange &r ATTRIBUTE_UNUSED, bool range_operator::op2_range (frange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const frange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const frange &lhs ATTRIBUTE_UNUSED, + const frange &op1 ATTRIBUTE_UNUSED, + relation_trio) const { return false; } bool range_operator::op2_range (frange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const irange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const irange &lhs ATTRIBUTE_UNUSED, + const frange &op1 ATTRIBUTE_UNUSED, + relation_trio) const { return false; } relation_kind range_operator::lhs_op1_relation (const frange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_kind) const + const frange &op1 ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_kind) const { return VREL_VARYING; } relation_kind range_operator::lhs_op1_relation (const irange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_kind) const + const frange &op1 ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_kind) const { return VREL_VARYING; } relation_kind range_operator::lhs_op2_relation (const irange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_kind) const + const frange &op1 ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_kind) const { return VREL_VARYING; } relation_kind range_operator::lhs_op2_relation (const frange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_kind) const + const frange &op1 ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_kind) const { return VREL_VARYING; } @@ -675,9 +675,9 @@ operator_equal::fold_range (irange &r, tree type, bool operator_equal::op1_range (frange &r, tree type, - const irange &lhs, - const frange &op2, - relation_trio trio) const + const irange &lhs, + const frange &op2, + relation_trio trio) const { relation_kind rel = trio.op1_op2 (); switch (get_bool_state (r, lhs, type)) @@ -1871,10 +1871,10 @@ public: bool foperator_unordered_gt::op1_range (frange &r, - tree type, - const irange &lhs, - const frange &op2, - relation_trio) const + tree type, + const irange &lhs, + const frange &op2, + relation_trio) const { switch (get_bool_state (r, lhs, type)) { @@ -2899,36 +2899,296 @@ private: } } fop_div; +bool +operator_cast::fold_range (frange &r, tree type, const frange &op1, + const frange &, relation_trio) const +{ + REAL_VALUE_TYPE lb, ub; + enum machine_mode mode = TYPE_MODE (type); + bool mode_composite = MODE_COMPOSITE_P (mode); + + if (empty_range_varying (r, type, op1, op1)) + return true; + if (!MODE_HAS_NANS (mode) && op1.maybe_isnan ()) + { + r.set_varying (type); + return true; + } + if (op1.known_isnan ()) + { + r.set_nan (type); + return true; + } + + const REAL_VALUE_TYPE &lh_lb = op1.lower_bound (); + const REAL_VALUE_TYPE &lh_ub = op1.upper_bound (); + real_convert (&lb, mode, &lh_lb); + real_convert (&ub, mode, &lh_ub); + + if (flag_rounding_math) + { + if (real_less (&lh_lb, &lb)) + { + if (mode_composite + && (real_isdenormal (&lb, mode) || real_iszero (&lb))) + { + // IBM extended denormals only have DFmode precision. + REAL_VALUE_TYPE tmp, tmp2; + real_convert (&tmp2, DFmode, &lh_lb); + real_nextafter (&tmp, REAL_MODE_FORMAT (DFmode), &tmp2, + &dconstninf); + real_convert (&lb, mode, &tmp); + } + else + frange_nextafter (mode, lb, dconstninf); + } + if (real_less (&ub, &lh_ub)) + { + if (mode_composite + && (real_isdenormal (&ub, mode) || real_iszero (&ub))) + { + // IBM extended denormals only have DFmode precision. + REAL_VALUE_TYPE tmp, tmp2; + real_convert (&tmp2, DFmode, &lh_ub); + real_nextafter (&tmp, REAL_MODE_FORMAT (DFmode), &tmp2, + &dconstinf); + real_convert (&ub, mode, &tmp); + } + else + frange_nextafter (mode, ub, dconstinf); + } + } + + r.set (type, lb, ub, op1.get_nan_state ()); + + if (flag_trapping_math + && MODE_HAS_INFINITIES (TYPE_MODE (type)) + && r.known_isinf () + && !op1.known_isinf ()) + { + REAL_VALUE_TYPE inf = r.lower_bound (); + if (real_isneg (&inf)) + { + REAL_VALUE_TYPE min = real_min_representable (type); + r.set (type, inf, min); + } + else + { + REAL_VALUE_TYPE max = real_max_representable (type); + r.set (type, max, inf); + } + } + + r.flush_denormals_to_zero (); + return true; +} + +// Implement fold for a cast from float to another float. +bool +operator_cast::op1_range (frange &r, tree type, const frange &lhs, + const frange &op2, relation_trio) const +{ + if (lhs.undefined_p ()) + return false; + tree lhs_type = lhs.type (); + enum machine_mode mode = TYPE_MODE (type); + enum machine_mode lhs_mode = TYPE_MODE (lhs_type); + frange wlhs; + bool rm; + if (REAL_MODE_FORMAT (mode)->ieee_bits + && REAL_MODE_FORMAT (lhs_mode)->ieee_bits + && (REAL_MODE_FORMAT (lhs_mode)->ieee_bits + >= REAL_MODE_FORMAT (mode)->ieee_bits) + && pow2p_hwi (REAL_MODE_FORMAT (mode)->ieee_bits)) + { + /* If the cast is widening from IEEE exchange mode to + wider exchange mode or extended mode, no need to extend + the range on reverse operation. */ + rm = false; + wlhs = lhs; + } + else + { + rm = true; + wlhs = float_widen_lhs_range (lhs_type, lhs); + } + auto save_flag_rounding_math = flag_rounding_math; + flag_rounding_math = rm; + bool ret = float_binary_op_range_finish (fold_range (r, type, wlhs, op2), + r, type, lhs); + flag_rounding_math = save_flag_rounding_math; + return ret; +} + // Implement fold for a cast from float to an int. bool -operator_cast::fold_range (irange &, tree, const frange &, +operator_cast::fold_range (irange &r, tree type, const frange &op1, const irange &, relation_trio) const { - return false; + if (empty_range_varying (r, type, op1, op1)) + return true; + if (op1.maybe_isnan () || op1.maybe_isinf ()) + { + r.set_varying (type); + return true; + } + REAL_VALUE_TYPE lb, ub; + real_trunc (&lb, VOIDmode, &op1.lower_bound ()); + real_trunc (&ub, VOIDmode, &op1.upper_bound ()); + REAL_VALUE_TYPE l, u; + l = real_value_from_int_cst (NULL_TREE, TYPE_MIN_VALUE (type)); + if (real_less (&lb, &l)) + { + r.set_varying (type); + return true; + } + u = real_value_from_int_cst (NULL_TREE, TYPE_MAX_VALUE (type)); + if (real_less (&u, &ub)) + { + r.set_varying (type); + return true; + } + bool fail = false; + wide_int wlb = real_to_integer (&lb, &fail, TYPE_PRECISION (type)); + wide_int wub = real_to_integer (&ub, &fail, TYPE_PRECISION (type)); + if (fail) + { + r.set_varying (type); + return true; + } + r.set (type, wlb, wub); + return true; } // Implement op1_range for a cast from float to an int. bool -operator_cast::op1_range (frange &, tree, const irange &, - const irange &, relation_trio) const +operator_cast::op1_range (frange &r, tree type, const irange &lhs, + const frange &, relation_trio) const { - return false; + if (lhs.undefined_p ()) + return false; + REAL_VALUE_TYPE lb, lbo, ub, ubo; + wide_int lhs_lb = lhs.lower_bound (); + wide_int lhs_ub = lhs.upper_bound (); + tree lhs_type = lhs.type (); + enum machine_mode mode = TYPE_MODE (type); + real_from_integer (&lbo, VOIDmode, lhs_lb, TYPE_SIGN (lhs_type)); + real_from_integer (&ubo, VOIDmode, lhs_ub, TYPE_SIGN (lhs_type)); + real_convert (&lb, mode, &lbo); + real_convert (&ub, mode, &ubo); + if (real_identical (&lb, &lbo)) + { + /* If low bound is exactly representable in type, + use nextafter (lb - 1., +inf). */ + real_arithmetic (&lb, PLUS_EXPR, &lbo, &dconstm1); + real_convert (&lb, mode, &lb); + if (!real_identical (&lb, &lbo)) + frange_nextafter (mode, lb, dconstinf); + if (real_identical (&lb, &lbo)) + frange_nextafter (mode, lb, dconstninf); + } + else if (real_less (&lbo, &lb)) + frange_nextafter (mode, lb, dconstninf); + if (real_identical (&ub, &ubo)) + { + /* If upper bound is exactly representable in type, + use nextafter (ub + 1., -inf). */ + real_arithmetic (&ub, PLUS_EXPR, &ubo, &dconst1); + real_convert (&ub, mode, &ub); + if (!real_identical (&ub, &ubo)) + frange_nextafter (mode, ub, dconstninf); + if (real_identical (&ub, &ubo)) + frange_nextafter (mode, ub, dconstinf); + } + else if (real_less (&ub, &ubo)) + frange_nextafter (mode, ub, dconstinf); + r.set (type, lb, ub, nan_state (false)); + return true; } // Implement fold for a cast from int to a float. bool -operator_cast::fold_range (frange &, tree, const irange &, +operator_cast::fold_range (frange &r, tree type, const irange &op1, const frange &, relation_trio) const { - return false; + if (empty_range_varying (r, type, op1, op1)) + return true; + REAL_VALUE_TYPE lb, ub; + wide_int op1_lb = op1.lower_bound (); + wide_int op1_ub = op1.upper_bound (); + tree op1_type = op1.type (); + enum machine_mode mode = flag_rounding_math ? VOIDmode : TYPE_MODE (type); + real_from_integer (&lb, mode, op1_lb, TYPE_SIGN (op1_type)); + real_from_integer (&ub, mode, op1_ub, TYPE_SIGN (op1_type)); + if (flag_rounding_math) + { + REAL_VALUE_TYPE lbo = lb, ubo = ub; + mode = TYPE_MODE (type); + real_convert (&lb, mode, &lb); + real_convert (&ub, mode, &ub); + if (real_less (&lbo, &lb)) + frange_nextafter (mode, lb, dconstninf); + if (real_less (&ub, &ubo)) + frange_nextafter (mode, ub, dconstinf); + } + r.set (type, lb, ub, nan_state (false)); + frange_drop_infs (r, type); + if (r.undefined_p ()) + r.set_varying (type); + return true; } // Implement op1_range for a cast from int to a float. bool -operator_cast::op1_range (irange &, tree, const frange &, - const frange &, relation_trio) const +operator_cast::op1_range (irange &r, tree type, const frange &lhs, + const irange &, relation_trio) const { - return false; + if (lhs.undefined_p ()) + return false; + if (lhs.known_isnan ()) + { + r.set_varying (type); + return true; + } + REAL_VALUE_TYPE lb = lhs.lower_bound (); + REAL_VALUE_TYPE ub = lhs.upper_bound (); + enum machine_mode mode = TYPE_MODE (lhs.type ()); + frange_nextafter (mode, lb, dconstninf); + frange_nextafter (mode, ub, dconstinf); + if (flag_rounding_math) + { + real_floor (&lb, mode, &lb); + real_ceil (&ub, mode, &ub); + } + else + { + real_trunc (&lb, mode, &lb); + real_trunc (&ub, mode, &ub); + } + REAL_VALUE_TYPE l, u; + wide_int wlb, wub; + l = real_value_from_int_cst (NULL_TREE, TYPE_MIN_VALUE (type)); + if (real_less (&lb, &l)) + wlb = wi::min_value (TYPE_PRECISION (type), TYPE_SIGN (type)); + else + { + bool fail = false; + wlb = real_to_integer (&lb, &fail, TYPE_PRECISION (type)); + if (fail) + wlb = wi::min_value (TYPE_PRECISION (type), TYPE_SIGN (type)); + } + u = real_value_from_int_cst (NULL_TREE, TYPE_MAX_VALUE (type)); + if (real_less (&u, &ub)) + wub = wi::max_value (TYPE_PRECISION (type), TYPE_SIGN (type)); + else + { + bool fail = false; + wub = real_to_integer (&ub, &fail, TYPE_PRECISION (type)); + if (fail) + wub = wi::max_value (TYPE_PRECISION (type), TYPE_SIGN (type)); + } + r.set (type, wlb, wub); + return true; } // Initialize any float operators to the primary table diff --git a/gcc/range-op-mixed.h b/gcc/range-op-mixed.h index 3fb7bff..f8f1830 100644 --- a/gcc/range-op-mixed.h +++ b/gcc/range-op-mixed.h @@ -473,14 +473,15 @@ public: bool fold_range (prange &r, tree type, const irange &op1, const prange &op2, relation_trio rel = TRIO_VARYING) const final override; + bool fold_range (frange &r, tree type, + const frange &op1, const frange &op2, + relation_trio = TRIO_VARYING) const final override; bool fold_range (irange &r, tree type, - const frange &lh, - const irange &rh, - relation_trio = TRIO_VARYING) const; + const frange &op1, const irange &op2, + relation_trio = TRIO_VARYING) const final override; bool fold_range (frange &r, tree type, - const irange &lh, - const frange &rh, - relation_trio = TRIO_VARYING) const; + const irange &op1, const frange &op2, + relation_trio = TRIO_VARYING) const final override; bool op1_range (irange &r, tree type, const irange &lhs, const irange &op2, @@ -495,13 +496,14 @@ public: const irange &lhs, const prange &op2, relation_trio rel = TRIO_VARYING) const final override; bool op1_range (frange &r, tree type, - const irange &lhs, - const irange &op2, - relation_trio = TRIO_VARYING) const; + const frange &lhs, const frange &op2, + relation_trio = TRIO_VARYING) const final override; + bool op1_range (frange &r, tree type, + const irange &lhs, const frange &op2, + relation_trio = TRIO_VARYING) const final override; bool op1_range (irange &r, tree type, - const frange &lhs, - const frange &op2, - relation_trio = TRIO_VARYING) const; + const frange &lhs, const irange &op2, + relation_trio = TRIO_VARYING) const final override; relation_kind lhs_op1_relation (const irange &lhs, const irange &op1, const irange &op2, diff --git a/gcc/range-op.cc b/gcc/range-op.cc index e2b9c82..0a3f0b6 100644 --- a/gcc/range-op.cc +++ b/gcc/range-op.cc @@ -97,6 +97,8 @@ range_op_table::range_op_table () set (INTEGER_CST, op_cst); set (NOP_EXPR, op_cast); set (CONVERT_EXPR, op_cast); + set (FLOAT_EXPR, op_cast); + set (FIX_TRUNC_EXPR, op_cast); set (PLUS_EXPR, op_plus); set (ABS_EXPR, op_abs); set (MINUS_EXPR, op_minus); @@ -165,7 +167,7 @@ dispatch_trio (unsigned lhs, unsigned op1, unsigned op2) // of the routines in range_operator. Note the last 3 characters are // shorthand for the LHS, OP1, and OP2 range discriminator class. // Reminder, single operand instructions use the LHS type for op2, even if -// unused. so FLOAT = INT would be RO_FIF. +// unused. So FLOAT = INT would be RO_FIF. const unsigned RO_III = dispatch_trio (VR_IRANGE, VR_IRANGE, VR_IRANGE); const unsigned RO_IFI = dispatch_trio (VR_IRANGE, VR_FRANGE, VR_IRANGE); @@ -298,10 +300,10 @@ range_op_handler::op1_range (vrange &r, tree type, return m_operator->op1_range (as_a <irange> (r), type, as_a <irange> (lhs), as_a <irange> (op2), rel); - case RO_IFF: + case RO_IFI: return m_operator->op1_range (as_a <irange> (r), type, as_a <frange> (lhs), - as_a <frange> (op2), rel); + as_a <irange> (op2), rel); case RO_PPP: return m_operator->op1_range (as_a <prange> (r), type, as_a <prange> (lhs), @@ -322,10 +324,6 @@ range_op_handler::op1_range (vrange &r, tree type, return m_operator->op1_range (as_a <frange> (r), type, as_a <irange> (lhs), as_a <frange> (op2), rel); - case RO_FII: - return m_operator->op1_range (as_a <frange> (r), type, - as_a <irange> (lhs), - as_a <irange> (op2), rel); case RO_FFF: return m_operator->op1_range (as_a <frange> (r), type, as_a <frange> (lhs), @@ -778,21 +776,14 @@ range_operator::fold_range (irange &r, tree type, bool range_operator::fold_range (frange &, tree, const irange &, - const frange &, relation_trio) const + const frange &, relation_trio) const { return false; } bool range_operator::op1_range (irange &, tree, const frange &, - const frange &, relation_trio) const -{ - return false; -} - -bool -range_operator::op1_range (frange &, tree, const irange &, - const irange &, relation_trio) const + const irange &, relation_trio) const { return false; } @@ -855,10 +846,13 @@ range_operator::op1_op2_relation (const irange &lhs ATTRIBUTE_UNUSED, bool range_operator::op1_op2_relation_effect (irange &lhs_range ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const irange &op1_range ATTRIBUTE_UNUSED, - const irange &op2_range ATTRIBUTE_UNUSED, - relation_kind rel ATTRIBUTE_UNUSED) const + tree type ATTRIBUTE_UNUSED, + const irange &op1_range + ATTRIBUTE_UNUSED, + const irange &op2_range + ATTRIBUTE_UNUSED, + relation_kind rel + ATTRIBUTE_UNUSED) const { return false; } @@ -874,7 +868,7 @@ range_operator::overflow_free_p (const irange &, const irange &, void range_operator::update_bitmask (irange &, const irange &, - const irange &) const + const irange &) const { } @@ -1815,7 +1809,7 @@ operator_plus::wi_fold (irange &r, tree type, static relation_kind plus_minus_ranges (irange &r_ov, irange &r_normal, const irange &offset, - bool add_p) + bool add_p) { relation_kind kind = VREL_VARYING; // For now, only deal with constant adds. This could be extended to ranges @@ -3349,9 +3343,9 @@ wi_optimize_signed_bitwise_op (irange &r, tree type, relation_kind operator_bitwise_and::lhs_op1_relation (const irange &lhs, - const irange &op1, - const irange &op2, - relation_kind) const + const irange &op1, + const irange &op2, + relation_kind) const { if (lhs.undefined_p () || op1.undefined_p () || op2.undefined_p ()) return VREL_VARYING; diff --git a/gcc/range-op.h b/gcc/range-op.h index 1075786..9e0e651 100644 --- a/gcc/range-op.h +++ b/gcc/range-op.h @@ -152,10 +152,6 @@ public: relation_trio = TRIO_VARYING) const; virtual bool op1_range (irange &r, tree type, const frange &lhs, - const frange &op2, - relation_trio = TRIO_VARYING) const; - virtual bool op1_range (frange &r, tree type, - const irange &lhs, const irange &op2, relation_trio = TRIO_VARYING) const; diff --git a/gcc/real.cc b/gcc/real.cc index b64bad0..95a9332 100644 --- a/gcc/real.cc +++ b/gcc/real.cc @@ -2230,7 +2230,6 @@ real_from_integer (REAL_VALUE_TYPE *r, format_helper fmt, { unsigned int len = val_in.get_precision (); int i, j, e = 0; - int maxbitlen = MAX_BITSIZE_MODE_ANY_INT + HOST_BITS_PER_WIDE_INT; const unsigned int realmax = (SIGNIFICAND_BITS / HOST_BITS_PER_WIDE_INT * HOST_BITS_PER_WIDE_INT); @@ -2238,12 +2237,6 @@ real_from_integer (REAL_VALUE_TYPE *r, format_helper fmt, r->cl = rvc_normal; r->sign = wi::neg_p (val_in, sgn); - /* We have to ensure we can negate the largest negative number. */ - wide_int val = wide_int::from (val_in, maxbitlen, sgn); - - if (r->sign) - val = -val; - /* Ensure a multiple of HOST_BITS_PER_WIDE_INT, ceiling, as elt won't work with precisions that are not a multiple of HOST_BITS_PER_WIDE_INT. */ @@ -2252,7 +2245,13 @@ real_from_integer (REAL_VALUE_TYPE *r, format_helper fmt, /* Ensure we can represent the largest negative number. */ len += 1; - len = len/HOST_BITS_PER_WIDE_INT * HOST_BITS_PER_WIDE_INT; + len = len / HOST_BITS_PER_WIDE_INT * HOST_BITS_PER_WIDE_INT; + + /* We have to ensure we can negate the largest negative number. */ + wide_int val = wide_int::from (val_in, len, sgn); + + if (r->sign) + val = -val; /* Cap the size to the size allowed by real.h. */ if (len > realmax) @@ -2260,14 +2259,18 @@ real_from_integer (REAL_VALUE_TYPE *r, format_helper fmt, HOST_WIDE_INT cnt_l_z; cnt_l_z = wi::clz (val); - if (maxbitlen - cnt_l_z > realmax) + if (len - cnt_l_z > realmax) { - e = maxbitlen - cnt_l_z - realmax; + e = len - cnt_l_z - realmax; /* This value is too large, we must shift it right to preserve all the bits we can, and then bump the - exponent up by that amount. */ - val = wi::lrshift (val, e); + exponent up by that amount, but or in 1 if any of + the shifted out bits are non-zero. */ + if (wide_int::from (val, e, UNSIGNED) != 0) + val = wi::set_bit (wi::lrshift (val, e), 0); + else + val = wi::lrshift (val, e); } len = realmax; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ff68455..8f9ad09 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,269 @@ +2025-06-05 Jeff Law <jlaw@ventanamicro.com> + + * gcc.target/riscv/nozicond-3.c: New test. + +2025-06-05 Uros Bizjak <ubizjak@gmail.com> + + PR target/120553 + * gcc.target/i386/pr120553.c: New test. + +2025-06-05 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/120231 + * gcc.dg/tree-ssa/pr120231-2.c: New test. + * gcc.dg/tree-ssa/pr120231-3.c: New test. + * gfortran.dg/inline_matmul_16.f90: Don't expect any _gfortran_matmul + strings in optimized dump. + * gfortran.dg/inline_matmul_26.f90: New test. + * g++.dg/tree-ssa/loop-split-1.C (d): New variable. + (main): Use std::log (i + d) instead of std::log (i). + +2025-06-05 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/89606 + * gcc.target/aarch64/vld2-1.c: New test. + +2025-06-05 Patrick Palka <ppalka@redhat.com> + + PR c++/120224 + * g++.dg/cpp0x/alias-decl-80.C: New test. + +2025-06-05 Jakub Jelinek <jakub@redhat.com> + + PR middle-end/120547 + * gcc.dg/bitint-123.c: New test. + +2025-06-05 Jeff Law <jlaw@ventanamicro.com> + + * gcc.target/riscv/nozicond-1.c: New test. + * gcc.target/riscv/nozicond-2.c: New test. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-ssu64xl.c: New test. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-sstvecd.c: New test. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-sstvala.c: New test. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-sscounterenw.c: New test. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-ssccptr.c: New test. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-smrnmi.c: New test. + +2025-06-05 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-smcsrind.c: New test. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/specs/opt7.ads: New test. + * gnat.dg/specs/opt7_pkg.ads: New helper. + * gnat.dg/specs/opt7_pkg.adb: Likewise. + +2025-06-05 Spencer Abson <spencer.abson@arm.com> + + * gcc.target/aarch64/sve/pr96357.c: Change to avoid producing + a conditional FIX_TRUNC_EXPR, whilst still reproducing the bug + in PR96357. + * gcc.dg/tree-ssa/ifcvt-fix-trunc-1.c: New test. + * gcc.dg/tree-ssa/ifcvt-fix-trunc-2.c: Likewise. + +2025-06-05 Hongyu Wang <hongyu.wang@intel.com> + + * g++.target/i386/pr112824-2.C: New test. + +2025-06-04 Kugan Vivekanandarajah <kvivekananda@nvidia.com> + + * gcc.dg/tree-prof/clone-merge-1.c: New test. + +2025-06-04 Jason Merrill <jason@redhat.com> + + PR c++/120502 + * g++.dg/cpp2a/constexpr-prvalue2.C: New test. + +2025-06-04 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/14295 + PR tree-optimization/108358 + PR tree-optimization/114169 + * gcc.dg/tree-ssa/20031106-6.c: Un-xfail. Add scan for forwprop1. + * g++.dg/opt/pr66119.C: Disable forwprop since that does + the copy prop now. + * gcc.dg/tree-ssa/pr108358-a.c: New test. + * gcc.dg/tree-ssa/pr114169-1.c: New test. + * gcc.c-torture/execute/builtins/pr22237-1-lib.c: New test. + * gcc.c-torture/execute/builtins/pr22237-1.c: New test. + * gcc.dg/tree-ssa/pr57361.c: Disable forwprop1. + * gcc.dg/tree-ssa/pr57361-1.c: New test. + +2025-06-04 Pengfei Li <Pengfei.Li2@arm.com> + + * gcc.target/aarch64/acle/uhadd_1.c: New test. + +2025-06-04 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/120231 + * gcc.dg/tree-ssa/pr120231-1.c: New test. + +2025-06-04 Dongyan Chen <chendongyan@isrc.iscas.ac.cn> + + * gcc.target/riscv/arch-60.c: New test. + +2025-06-04 Richard Sandiford <richard.sandiford@arm.com> + + PR rtl-optimization/120447 + * gcc.dg/pr120447.c: New test. + +2025-06-04 H.J. Lu <hjl.tools@gmail.com> + + PR debug/120525 + * gcc.dg/pr120525.c: New test. + +2025-06-04 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120483 + * gfortran.dg/save_8.f90: New test. + +2025-06-04 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-shlocofideleg.c: New test. + +2025-06-04 Hu, Lin1 <lin1.hu@intel.com> + + * gcc.target/i386/pr49095-2.c: New test. + +2025-06-04 Hu, Lin1 <lin1.hu@intel.com> + + * gcc.target/i386/pr79173-13.c: New test. + * gcc.target/i386/pr79173-14.c: Ditto. + * gcc.target/i386/pr79173-15.c: Ditto. + * gcc.target/i386/pr79173-16.c: Ditto. + * gcc.target/i386/pr79173-17.c: Ditto. + * gcc.target/i386/pr79173-18.c: Ditto. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99838 + * gfortran.dg/coarray_data_2.f90: New test. + +2025-06-03 Martin Uecker <uecker@tugraz.at> + + PR c/120078 + * gcc.dg/Wjump-misses-init-3.c: New test. + +2025-06-03 Martin Uecker <uecker@tugraz.at> + + * gcc.dg/gnu23-tag-composite-6.c: Update. + +2025-06-03 Martin Uecker <uecker@tugraz.at> + + PR c/116892 + * gcc.dg/pr116892.c: New test. + +2025-06-03 Jason Merrill <jason@redhat.com> + + * g++.dg/modules/cpp-1.C + * g++.dg/modules/cpp-3.C + * g++.dg/modules/cpp-4.C: Specify -fno-modules. + +2025-06-03 Pan Li <pan2.li@intel.com> + + * gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c: Adjust + the asm check for vdiv. + * gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c: Ditto. + * gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c: Ditto. + * gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c: Ditto. + +2025-06-03 Pan Li <pan2.li@intel.com> + + * gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c: Add asm check + check for vdiv.vx combine. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c: Ditto. + +2025-06-03 Pan Li <pan2.li@intel.com> + + * gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c: Add asm check + for vdiv.vx combine. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h: Add test + data for vdiv run test. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i8.c: New test. + +2025-06-03 Paul-Antoine Arras <parras@baylibre.com> + + PR target/119100 + * gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop.h: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_data.h: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_run.h: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f64.c: New test. + +2025-06-03 H.J. Lu <hjl.tools@gmail.com> + + PR target/103750 + * g++.target/i386/pr103750.C: New test. + +2025-06-03 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/116824 + * gcc.dg/tree-ssa/phiprop-2.c: New test. + +2025-06-03 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/120451 + * gcc.dg/tree-ssa/cswtch-6.c: New test. + 2025-06-02 Alexandre Oliva <oliva@adacore.com> PR rtl-optimization/120424 diff --git a/gcc/testsuite/g++.dg/cpp0x/alias-decl-80.C b/gcc/testsuite/g++.dg/cpp0x/alias-decl-80.C new file mode 100644 index 0000000..9c0eadc --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/alias-decl-80.C @@ -0,0 +1,21 @@ +// PR c++/120224 +// { dg-do compile { target c++11 } } + +template<class> using void_t = void; + +template<class T> +void f(void*); // #1 + +template<class T> +void f(void_t<typename T::type>*) { } // { dg-error "not a class" } defn of #1 + +template<class T> +void g(int, void*); // #2 + +template<class T> +void g(int, void_t<typename T::type>*) { } // { dg-error "not a class" } defn of #2 + +int main() { + f<int>(0); // { dg-error "no match" } + g<int>(0, 0); // { dg-error "no match" } +} diff --git a/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C b/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C new file mode 100644 index 0000000..c2dc7cd --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C @@ -0,0 +1,26 @@ +// PR c++/120502 +// { dg-do compile { target c++20 } } +// { dg-additional-options -O } + +struct non_trivial_if { + constexpr non_trivial_if() {} +}; +struct allocator : non_trivial_if {}; +struct padding {}; +struct __short { + [[no_unique_address]] padding p; +}; +struct basic_string { + union { + __short s; + int l; + }; + [[no_unique_address]] allocator a; + constexpr basic_string() {} + ~basic_string() {} +}; +struct time_zone { + basic_string __abbrev; + long __offset; +}; +time_zone convert_to_time_zone() { return {}; } diff --git a/gcc/testsuite/g++.dg/modules/cpp-1.C b/gcc/testsuite/g++.dg/modules/cpp-1.C index 2ad9637..56ef05fe 100644 --- a/gcc/testsuite/g++.dg/modules/cpp-1.C +++ b/gcc/testsuite/g++.dg/modules/cpp-1.C @@ -1,4 +1,5 @@ // { dg-do preprocess } +// { dg-additional-options -fno-modules } module bob; #if 1 @@ -11,4 +12,4 @@ import gru; EXPORT import mabel; int i; -// { dg-final { scan-file cpp-1.i "cpp-1.C\"\n\n\nmodule bob;\n\nexport import stuart;\n\n\n\nimport gru;\n\n import mabel;\n" } } +// { dg-final { scan-file cpp-1.i "cpp-1.C\"\n\n\n\nmodule bob;\n\nexport import stuart;\n\n\n\nimport gru;\n\n import mabel;\n" } } diff --git a/gcc/testsuite/g++.dg/modules/cpp-3.C b/gcc/testsuite/g++.dg/modules/cpp-3.C index 3aa0c6e..cd776ae 100644 --- a/gcc/testsuite/g++.dg/modules/cpp-3.C +++ b/gcc/testsuite/g++.dg/modules/cpp-3.C @@ -1,4 +1,5 @@ // { dg-do preprocess } +// { dg-additional-options -fno-modules } #define NAME(X) X; diff --git a/gcc/testsuite/g++.dg/modules/cpp-4.C b/gcc/testsuite/g++.dg/modules/cpp-4.C index 6c19431..c423de2 100644 --- a/gcc/testsuite/g++.dg/modules/cpp-4.C +++ b/gcc/testsuite/g++.dg/modules/cpp-4.C @@ -1,3 +1,4 @@ +// { dg-additional-options -fno-modules } // { dg-do preprocess } #if 1 diff --git a/gcc/testsuite/g++.dg/opt/pr66119.C b/gcc/testsuite/g++.dg/opt/pr66119.C index d1b1845..52362e4 100644 --- a/gcc/testsuite/g++.dg/opt/pr66119.C +++ b/gcc/testsuite/g++.dg/opt/pr66119.C @@ -3,7 +3,7 @@ the value of MOVE_RATIO now is. */ /* { dg-do compile { target { { i?86-*-* x86_64-*-* } && c++11 } } } */ -/* { dg-options "-O3 -mavx -fdump-tree-sra -march=slm -mtune=slm -fno-early-inlining" } */ +/* { dg-options "-O3 -mavx -fdump-tree-sra -fno-tree-forwprop -march=slm -mtune=slm -fno-early-inlining" } */ // { dg-skip-if "requires hosted libstdc++ for cstdlib malloc" { ! hostedlib } } #include <immintrin.h> diff --git a/gcc/testsuite/g++.dg/tree-ssa/loop-split-1.C b/gcc/testsuite/g++.dg/tree-ssa/loop-split-1.C index 8981006..4df85f5 100644 --- a/gcc/testsuite/g++.dg/tree-ssa/loop-split-1.C +++ b/gcc/testsuite/g++.dg/tree-ssa/loop-split-1.C @@ -6,6 +6,7 @@ #include <cmath> constexpr unsigned s = 100000000; +double d = 0.0; int main() { @@ -19,7 +20,7 @@ int main() if(i == 0) a[i] = b[i] * c[i]; else - a[i] = (b[i] + c[i]) * c[i-1] * std::log(i); + a[i] = (b[i] + c[i]) * c[i-1] * std::log(i + d); } } /* { dg-final { scan-tree-dump-times "loop split" 1 "lsplit" } } */ diff --git a/gcc/testsuite/g++.target/i386/pr103750.C b/gcc/testsuite/g++.target/i386/pr103750.C new file mode 100644 index 0000000..c82c10a --- /dev/null +++ b/gcc/testsuite/g++.target/i386/pr103750.C @@ -0,0 +1,39 @@ +/* { dg-do compile } */ +/* { dg-options "-O3 -march=x86-64-v4 -std=c++17" } */ +/* Keep labels and directives ('.cfi_startproc', '.cfi_endproc'). */ +/* { dg-final { check-function-bodies "**" "" "" { target "*-*-*" } {^\t?\.} } } */ + +#include <x86intrin.h> + +/* +**_Z8qustrchrPDsS_Ds: +**... +**.L[0-9]+: +** vpcmpeqw \(%[a-x]+\), %ymm0, %k1 +** vpcmpeqw 32\(%[a-x]+\), %ymm0, %k0 +** kortestw %k0, %k1 +** je .L[0-9]+ +**... +*/ + +const char16_t * +qustrchr(char16_t *n, char16_t *e, char16_t c) noexcept +{ + __m256i mch256 = _mm256_set1_epi16(c); + for ( ; n < e; n += 32) { + __m256i data1 = _mm256_loadu_si256(reinterpret_cast<const __m256i *>(n)); + __m256i data2 = _mm256_loadu_si256(reinterpret_cast<const __m256i *>(n) + 1); + __mmask16 mask1 = _mm256_cmpeq_epu16_mask(data1, mch256); + __mmask16 mask2 = _mm256_cmpeq_epu16_mask(data2, mch256); + if (_kortestz_mask16_u8(mask1, mask2)) + continue; + + unsigned idx = _tzcnt_u32(mask1); + if (mask1 == 0) { + idx = __tzcnt_u16(mask2); + n += 16; + } + return n + idx; + } + return e; +} diff --git a/gcc/testsuite/g++.target/i386/pr112824-2.C b/gcc/testsuite/g++.target/i386/pr112824-2.C new file mode 100644 index 0000000..036a47b --- /dev/null +++ b/gcc/testsuite/g++.target/i386/pr112824-2.C @@ -0,0 +1,10 @@ +/* PR target/112824 */ +/* { dg-do compile } */ +/* { dg-options "-std=c++23 -O3 -march=skylake-avx512 -mprefer-vector-width=512" } */ +/* { dg-final { scan-assembler-not "vmov.*\[ \\t\]+\[^\n\]*%rsp" } } */ + +#include "pr112824-1.C" + +void prod(Dual<Dual<double,8>,2> &c, const Dual<Dual<double,8>,2> &a, const Dual<Dual<double,8>,2>&b){ + c = a*b; +} diff --git a/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1-lib.c b/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1-lib.c new file mode 100644 index 0000000..4403235 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1-lib.c @@ -0,0 +1,27 @@ +extern void abort (void); + +void * +memcpy (void *dst, const void *src, __SIZE_TYPE__ n) +{ + const char *srcp; + char *dstp; + + srcp = src; + dstp = dst; + + if (dst < src) + { + if (dst + n > src) + abort (); + } + else + { + if (src + n > dst) + abort (); + } + + while (n-- != 0) + *dstp++ = *srcp++; + + return dst; +} diff --git a/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1.c b/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1.c new file mode 100644 index 0000000..0a12b0f --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1.c @@ -0,0 +1,57 @@ +extern void abort (void); +extern void exit (int); +struct s { unsigned char a[256]; }; +union u { struct { struct s b; int c; } d; struct { int c; struct s b; } e; }; +static union u v; +static union u v0; +static struct s *p = &v.d.b; +static struct s *q = &v.e.b; + +struct outers +{ + struct s inner; +}; + +static inline struct s rp (void) { return *p; } +static inline struct s rq (void) { return *q; } +static void pq (void) +{ + struct outers o = {rq () }; + *p = o.inner; +} +static void qp (void) +{ + struct outers o = {rp () }; + *q = o.inner; +} + +static void +init (struct s *sp) +{ + int i; + for (i = 0; i < 256; i++) + sp->a[i] = i; +} + +static void +check (struct s *sp) +{ + int i; + for (i = 0; i < 256; i++) + if (sp->a[i] != i) + abort (); +} + +void +main_test (void) +{ + v = v0; + init (p); + qp (); + check (q); + v = v0; + init (q); + pq (); + check (p); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/Wjump-misses-init-3.c b/gcc/testsuite/gcc.dg/Wjump-misses-init-3.c new file mode 100644 index 0000000..c3110c4 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wjump-misses-init-3.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-Wc++-compat" } */ + +void f() +{ + goto skip; /* { dg-warning "jump skips variable initialization" } */ + int i = 1; +skip: ; +} + diff --git a/gcc/testsuite/gcc.dg/bitint-123.c b/gcc/testsuite/gcc.dg/bitint-123.c new file mode 100644 index 0000000..4d019a9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/bitint-123.c @@ -0,0 +1,26 @@ +/* PR middle-end/120547 */ +/* { dg-do run { target bitint } } */ +/* { dg-options "-O2" } */ +/* { dg-add-options float64 } */ +/* { dg-require-effective-target float64 } */ + +#define CHECK(x, y) \ + if ((_Float64) x != (_Float64) y \ + || (_Float64) (x + 1) != (_Float64) (y + 1)) \ + __builtin_abort () + +int +main () +{ + unsigned long long a = 0x20000000000001ULL << 7; + volatile unsigned long long b = a; + CHECK (a, b); +#if __BITINT_MAXWIDTH__ >= 4096 + unsigned _BitInt(4096) c = ((unsigned _BitInt(4096)) 0x20000000000001ULL) << 253; + volatile unsigned _BitInt(4096) d = c; + CHECK (c, d); + unsigned _BitInt(4096) e = ((unsigned _BitInt(4096)) 0x20000000000001ULL) << 931; + volatile unsigned _BitInt(4096) f = e; + CHECK (e, f); +#endif +} diff --git a/gcc/testsuite/gcc.dg/gnu23-tag-composite-6.c b/gcc/testsuite/gcc.dg/gnu23-tag-composite-6.c index 2411b04..076c066 100644 --- a/gcc/testsuite/gcc.dg/gnu23-tag-composite-6.c +++ b/gcc/testsuite/gcc.dg/gnu23-tag-composite-6.c @@ -1,11 +1,31 @@ /* { dg-do compile } */ /* { dg-options "-std=gnu23" } */ +#define NEST(...) typeof(({ (__VA_ARGS__){ }; })) + int f() { typedef struct foo bar; - struct foo { typeof(({ (struct foo { bar * x; }){ }; })) * x; } *q; - typeof(q->x) p; - 1 ? p : q; + struct foo { NEST(struct foo { bar *x; }) *x; } *q; + typeof(q->x) p0; + typeof(q->x) p1; + 1 ? p0 : q; + 1 ? p1 : q; + 1 ? p0 : p1; +} + +int g() +{ + typedef struct fo2 bar; + struct fo2 { NEST(struct fo2 { NEST(struct fo2 { bar *x; }) * x; }) *x; } *q; + typeof(q->x) p0; + typeof(q->x->x) p1; + typeof(q->x->x->x) p2; + 1 ? p0 : q; + 1 ? p1 : q; + 1 ? p2 : q; + 1 ? p0 : p1; + 1 ? p2 : p1; + 1 ? p0 : p2; } diff --git a/gcc/testsuite/gcc.dg/pr116892.c b/gcc/testsuite/gcc.dg/pr116892.c new file mode 100644 index 0000000..7eb431b --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr116892.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* { dg-options "-g -std=gnu23" } */ + +enum fmt_type; + +void foo(const enum fmt_type a); + +enum [[gnu::packed]] fmt_type { + A +} const a; + diff --git a/gcc/testsuite/gcc.dg/pr120447.c b/gcc/testsuite/gcc.dg/pr120447.c new file mode 100644 index 0000000..bd51f9b --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr120447.c @@ -0,0 +1,24 @@ +/* { dg-options "-Ofast" } */ +/* { dg-additional-options "-mcpu=neoverse-v2" { target aarch64*-*-* } } */ + +char g; +long h; +typedef struct { + void *data; +} i; +i* a; +void b(i *j, char *p2); +void c(char *d) { + d = d ? " and " : " or "; + b(a, d); +} +void b(i *j, char *p2) { + h = __builtin_strlen(p2); + while (g) + ; + int *k = j->data; + char *l = p2, *m = p2 + h; + l += 4; + while (l < m) + *k++ = *l++; +} diff --git a/gcc/testsuite/gcc.dg/pr120525.c b/gcc/testsuite/gcc.dg/pr120525.c new file mode 100644 index 0000000..5ab7a22 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr120525.c @@ -0,0 +1,22 @@ +/* { dg-do compile { target fpic } } */ +/* { dg-options "-O2 -fpic -g" } */ +/* { dg-additional-options "-m31" { target s390x-*-* } } */ + +typedef __SIZE_TYPE__ uintptr_t; +static __thread uintptr_t start_sp; +static inline uintptr_t +__thread_stack_pointer (void) +{ + return (uintptr_t) __builtin_frame_address (0); +} + +void +update_data (void) +{ + if (__builtin_expect ((!start_sp), 0)) + start_sp = __thread_stack_pointer (); + + uintptr_t sp = __thread_stack_pointer (); + if (__builtin_expect ((sp > start_sp), 0)) + start_sp = sp; +} diff --git a/gcc/testsuite/gcc.dg/tree-prof/clone-merge-1.c b/gcc/testsuite/gcc.dg/tree-prof/clone-merge-1.c new file mode 100644 index 0000000..40aab9f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-prof/clone-merge-1.c @@ -0,0 +1,32 @@ +/* { dg-options "-O3 -fno-early-inlining -fdump-ipa-afdo-all" } */ +__attribute__ ((used)) +int a[1000]; + +__attribute__ ((noinline)) +void +test2(int sz) +{ + a[sz]++; + asm volatile (""::"m"(a)); +} + +__attribute__ ((noinline)) +void +test1 (int sz) +{ + for (int i = 0; i < 1000; i++) + if (i % 2) + test2 (sz); + else + test2 (i); + +} +int main() +{ + for (int i = 0; i < 1000; i++) + test1 (1000); + return 0; +} +/* We will have profiles for test2 and test2.constprop.0 that will have to be + merged, */ +/* { dg-final-use-autofdo { scan-ipa-dump "note: Merging profile for test2" "afdo"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20031106-6.c b/gcc/testsuite/gcc.dg/tree-ssa/20031106-6.c index 56d1887b..c7e0088 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/20031106-6.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/20031106-6.c @@ -1,5 +1,7 @@ /* { dg-do compile } */ -/* { dg-options "-O1 -fno-tree-sra -fdump-tree-optimized" } */ +/* { dg-options "-O1 -fno-tree-sra -fdump-tree-optimized -fdump-tree-forwprop1-details" } */ + +/* PR tree-optimization/14295 */ extern void link_error (void); @@ -25,4 +27,6 @@ struct s foo (struct s r) /* There should be no references to any of "temp_struct*" temporaries. */ -/* { dg-final { scan-tree-dump-times "temp_struct" 0 "optimized" { xfail *-*-* } } } */ +/* { dg-final { scan-tree-dump-times "temp_struct" 0 "optimized" } } */ +/* Also check that forwprop pass did the copy prop. */ +/* { dg-final { scan-tree-dump-times "after previous" 3 "forwprop1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-1.c new file mode 100644 index 0000000..801a53f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-1.c @@ -0,0 +1,19 @@ + /* { dg-do compile } */ + /* { dg-options "-O2 -ftree-vectorize -fdump-tree-ifcvt-stats" } */ + +void +test (int *dst, float *arr, int *pred, int n) +{ + for (int i = 0; i < n; i++) + { + int pred_i = pred[i]; + float arr_i = arr[i]; + + dst[i] = pred_i ? (int)arr_i : 5; + } +} + +/* We expect this to fail if_convertible_loop_p so long as we have no + conditional IFN for FIX_TRUNC_EXPR. */ + +/* { dg-final { scan-tree-dump-times "Applying if-conversion" 0 "ifcvt" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-2.c b/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-2.c new file mode 100644 index 0000000..628b754 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-2.c @@ -0,0 +1,6 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -ftree-vectorize -fno-trapping-math -fdump-tree-ifcvt-stats" } */ + +#include "ifcvt-fix-trunc-1.c" + +/* { dg-final { scan-tree-dump-times "Applying if-conversion" 1 "ifcvt" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr108358-a.c b/gcc/testsuite/gcc.dg/tree-ssa/pr108358-a.c new file mode 100644 index 0000000..342e1c1 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr108358-a.c @@ -0,0 +1,33 @@ +/* { dg-do compile } */ +/* { dg-options "-Os -fdump-tree-optimized" } */ + +/* PR tree-optimization/108358 */ + +struct a { + int b; + int c; + short d; + int e; + int f; +}; +struct g { + struct a f; + struct a h; +}; +int i; +void foo(); +void bar31_(void); +int main() { + struct g j, l = {2, 1, 6, 1, 1, 7, 5, 1, 0, 1}; + for (; i; ++i) + bar31_(); + j = l; + struct g m = j; + struct g k = m; + if (k.h.b) + ; + else + foo(); +} +/* The call to foo should be optimized away. */ +/* { dg-final { scan-tree-dump-not "foo " "optimized" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr114169-1.c b/gcc/testsuite/gcc.dg/tree-ssa/pr114169-1.c new file mode 100644 index 0000000..37766fb --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr114169-1.c @@ -0,0 +1,39 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-forwprop-details -fdump-tree-optimized" } */ + + +/* PR tree-optimization/114169 */ + +#include <stdint.h> + +struct S1 { + uint32_t f0; + uint8_t f1; + uint64_t f2; + uint64_t f3; + int32_t f4; +}; + +union U8 { + struct S1 f0; + int32_t f1; + int64_t f2; + uint8_t f3; + const int64_t f4; +}; + +/* --- GLOBAL VARIABLES --- */ +struct S1 g_16 = {4294967293UL,1UL,1UL,0xA9C1C73B017290B1LL,0x5ADF851FL}; +union U8 g_37 = {{1UL,1UL,0x2361AE7D51263067LL,0xEEFD7F9B64A47447LL,0L}}; +struct S1 g_50 = {0x0CFC2012L,1UL,0x43E1243B3BE7B8BBLL,0x03C5CEC10C1A6FE1LL,1L}; + + +/* --- FORWARD DECLARATIONS --- */ + +void func_32(union U8 e) { + e.f3 = e.f0.f4; + g_16 = e.f0 = g_50; +} +/* The union e should not make a difference here. */ +/* { dg-final { scan-tree-dump-times "after previous" 1 "forwprop1" } } */ +/* { dg-final { scan-tree-dump "g_16 = g_50;" "optimized" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr120231-1.c b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-1.c new file mode 100644 index 0000000..c1ce44f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-1.c @@ -0,0 +1,67 @@ +/* PR tree-optimization/120231 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-optimized" } */ +/* { dg-add-options float32 } */ +/* { dg-add-options float64 } */ +/* { dg-add-options float128 } */ +/* { dg-require-effective-target float32 } */ +/* { dg-require-effective-target float64 } */ +/* { dg-require-effective-target float128 } */ +/* { dg-final { scan-tree-dump-not "link_failure \\\(\\\);" "optimized" } } */ + +void link_failure (void); + +void +foo (_Float64 x) +{ + if (x >= -64.0f64 && x <= 0x1.p+140f64) + { + _Float32 z = x; + _Float128 w = z; + _Float128 v = x; + if (__builtin_isnan (z) + || __builtin_isnan (w) + || __builtin_isnan (v) + || z < -64.0f32 + || w < -64.0f128 + || __builtin_isinf (v) + || v < -64.0f128 + || v > 0x1.p+140f128) + link_failure (); + } +} + +void +bar (_Float64 x) +{ + _Float32 z = x; + if (z >= -64.0f32 && z <= 0x1.p+38f32) + { + if (__builtin_isnan (x) + || __builtin_isinf (x) + || x < -0x1.000001p+6f64 + || x > 0x1.000001p+38f64) + link_failure (); + } +} + +void +baz (_Float64 x) +{ + _Float128 w = x; + if (w >= -64.0f128 && w <= 0x1.p+1026f128) + { + if (__builtin_isnan (x) + || __builtin_isinf (x) + || x < -64.0f64) + link_failure (); + } + if (w >= 128.25f128 && w <= 0x1.p+1020f128) + { + if (__builtin_isnan (x) + || __builtin_isinf (x) + || x < 128.25f64 + || x > 0x1.p+1020f64) + link_failure (); + } +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr120231-2.c b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-2.c new file mode 100644 index 0000000..d2b41ba --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-2.c @@ -0,0 +1,107 @@ +/* PR tree-optimization/120231 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-optimized" } */ +/* { dg-add-options float64 } */ +/* { dg-require-effective-target float64 } */ +/* { dg-final { scan-tree-dump-not "link_failure \\\(\\\);" "optimized" } } */ + +void link_failure (void); + +static _Float64 __attribute__((noinline)) +f1 (signed char x) +{ + return x; +} + +static _Float64 __attribute__((noinline)) +f2 (signed char x) +{ + if (x >= -37 && x <= 42) + return x; + return 0.0f64; +} + +void +f3 (signed char x) +{ + _Float64 y = f1 (x); + if (y < (_Float64) (-__SCHAR_MAX__ - 1) || y > (_Float64) __SCHAR_MAX__) + link_failure (); + y = f2 (x); + if (y < -37.0f64 || y > 42.0f64) + link_failure (); +} + +static _Float64 __attribute__((noinline)) +f4 (long long x) +{ + return x; +} + +static _Float64 __attribute__((noinline)) +f5 (long long x) +{ + if (x >= -0x3ffffffffffffffeLL && x <= 0x3ffffffffffffffeLL) + return x; + return 0.0f64; +} + +void +f6 (long long x) +{ + _Float64 y = f4 (x); + if (y < (_Float64) (-__LONG_LONG_MAX__ - 1) || y > (_Float64) __LONG_LONG_MAX__) + link_failure (); + y = f5 (x); + if (y < (_Float64) -0x3ffffffffffffffeLL || y > (_Float64) 0x3ffffffffffffffeLL) + link_failure (); +} + +static signed char __attribute__((noinline)) +f7 (_Float64 x) +{ + if (x >= -78.5f64 && x <= 98.25f64) + return x; + return 0; +} + +static unsigned char __attribute__((noinline)) +f8 (_Float64 x) +{ + if (x >= -0.75f64 && x <= 231.625f64) + return x; + return 31; +} + +static long long __attribute__((noinline)) +f9 (_Float64 x) +{ + if (x >= -3372587051122780362.75f64 && x <= 3955322825938799366.25f64) + return x; + return 0; +} + +static unsigned long long __attribute__((noinline)) +f10 (_Float64 x) +{ + if (x >= 31.25f64 && x <= 16751991430751148048.125f64) + return x; + return 4700; +} + +void +f11 (_Float64 x) +{ + signed char a = f7 (x); + if (a < -78 || a > 98) + link_failure (); + unsigned char b = f8 (x); + if (b > 231) + link_failure (); + long long c = f9 (x); + if (c < -3372587051122780160LL || c > 3955322825938799616LL) + link_failure (); + unsigned long long d = f10 (x); + if (d < 31 || d > 16751991430751148032ULL) + link_failure (); +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr120231-3.c b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-3.c new file mode 100644 index 0000000..d578c5b --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-3.c @@ -0,0 +1,40 @@ +/* PR tree-optimization/120231 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-optimized" } */ +/* { dg-add-options float64 } */ +/* { dg-require-effective-target float64 } */ +/* { dg-final { scan-tree-dump-not "link_failure \\\(\\\);" "optimized" } } */ + +void link_failure (void); + +void +foo (long long x) +{ + _Float64 y = x; + if (y >= -8577328745032543176.25f64 && y <= 699563045341050951.75f64) + { + if (x < -8577328745032544256LL || x > 699563045341051136LL) + link_failure (); + } + if (y >= -49919160463252.125f64 && y <= 757060336735329.625f64) + { + if (x < -49919160463252LL || x > 757060336735329LL) + link_failure (); + } +} + +void +bar (_Float64 x) +{ + long long y = x; + if (y >= -6923230004751524066LL && y <= 2202103129706786704LL) + { + if (x < -6923230004751524864.0f64 || x > 2202103129706786816.0f64) + link_failure (); + } + if (y >= -171621738469699LL && y <= 45962470357748LL) + { + if (x <= -1716217384696970.f64 || x >= 45962470357749.0f64) + link_failure (); + } +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr57361-1.c b/gcc/testsuite/gcc.dg/tree-ssa/pr57361-1.c new file mode 100644 index 0000000..dc4fadb --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr57361-1.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-O -fdump-tree-forwprop1-details" } */ + +struct A { int x; double y; }; +void f (struct A *a) { + *a = *a; +} + +/* xfailed until figuring out the best way to handle aliasing barriers. */ +/* { dg-final { scan-tree-dump "into a NOP" "forwprop1" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr57361.c b/gcc/testsuite/gcc.dg/tree-ssa/pr57361.c index 81f27b3..7e273db 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr57361.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr57361.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O -fdump-tree-dse1-details" } */ +/* { dg-options "-O -fdump-tree-dse1-details -fno-tree-forwprop" } */ struct A { int x; double y; }; void f (struct A *a) { diff --git a/gcc/testsuite/gcc.target/aarch64/acle/uhadd_1.c b/gcc/testsuite/gcc.target/aarch64/acle/uhadd_1.c new file mode 100644 index 0000000..f1748a1 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/acle/uhadd_1.c @@ -0,0 +1,34 @@ +/* Test if SIMD fused unsigned halving adds are generated */ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +#include <arm_neon.h> + +#define FUSED_SIMD_UHADD(vectype, q, ts, mask) \ + vectype simd_uhadd ## q ## _ ## ts ## _1 (vectype a) \ + { \ + vectype v1 = vand ## q ## _ ## ts (a, vdup ## q ## _n_ ## ts (mask)); \ + vectype v2 = vdup ## q ## _n_ ## ts (mask); \ + return vshr ## q ## _n_ ## ts (vadd ## q ## _ ## ts (v1, v2), 1); \ + } \ + \ + vectype simd_uhadd ## q ## _ ## ts ## _2 (vectype a, vectype b) \ + { \ + vectype v1 = vand ## q ## _ ## ts (a, vdup ## q ## _n_ ## ts (mask)); \ + vectype v2 = vand ## q ## _ ## ts (b, vdup ## q ## _n_ ## ts (mask)); \ + return vshr ## q ## _n_ ## ts (vadd ## q ## _ ## ts (v1, v2), 1); \ + } + +FUSED_SIMD_UHADD (uint8x8_t, , u8, 0x7f) +FUSED_SIMD_UHADD (uint8x16_t, q, u8, 0x7f) +FUSED_SIMD_UHADD (uint16x4_t, , u16, 0x7fff) +FUSED_SIMD_UHADD (uint16x8_t, q, u16, 0x7fff) +FUSED_SIMD_UHADD (uint32x2_t, , u32, 0x7fffffff) +FUSED_SIMD_UHADD (uint32x4_t, q, u32, 0x7fffffff) + +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.8b,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.16b,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.4h,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.8h,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.2s,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.4s,} 2 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/sve/pr96357.c b/gcc/testsuite/gcc.target/aarch64/sve/pr96357.c index 9a7f912..6dd0409 100644 --- a/gcc/testsuite/gcc.target/aarch64/sve/pr96357.c +++ b/gcc/testsuite/gcc.target/aarch64/sve/pr96357.c @@ -5,10 +5,10 @@ int d; void f1(char f, char *g, char *h, char *l, char *n) { - double i = d, j = 1.0 - f, k = j ? d : j; - if (k == 1.0) - i = 0.0; - *l = *n = *g = *h = i * 0.5; + double j = 1.0 - f, k = j ? d : j; + + char i = (k == 1.0) ? 10 : 50; + *l = *n = *g = *h = i; } void diff --git a/gcc/testsuite/gcc.target/aarch64/vld2-1.c b/gcc/testsuite/gcc.target/aarch64/vld2-1.c new file mode 100644 index 0000000..8a26767 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/vld2-1.c @@ -0,0 +1,45 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-forwprop1-details" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ +/* PR tree-optimization/89606 */ + +#include <arm_neon.h> + +/* +**func1: +** ld2 {v0.2d - v1.2d}, \[x0\] +** ld2 {v0.d - v1.d}\[1\], \[x1\] +** ret +*/ +float64x2x2_t func1(const double *p1, const double *p2) +{ + float64x2x2_t v = vld2q_f64(p1); + return vld2q_lane_f64(p2, v, 1); +} + +/* +**func2: +** ld2 {v0.2s - v1.2s}, \[x0\] +** ld2 {v0.s - v1.s}\[1\], \[x1\] +** ret +*/ +float32x2x2_t func2(const float *p1, const float *p2) +{ + float32x2x2_t v = vld2_f32(p1); + return vld2_lane_f32(p2, v, 1); +} + +/* +**func3: +** ld2 {v([0-9]+).2s - v([0-9]+).2s}, \[x1\] +** ld2 {v\1.s - v\2.s}\[1\], \[x2\] +** stp d\1, d\2, \[x0\] +** ret +*/ +void func3(float32x2x2_t *p, const float *p1, const float *p2) +{ + float32x2x2_t v = vld2_f32(p1); + *p = vld2_lane_f32(p2, v, 1); +} + +/* { dg-final { scan-tree-dump-times "after previous" 3 "forwprop1" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr120032-1.c b/gcc/testsuite/gcc.target/i386/pr120032-1.c new file mode 100644 index 0000000..c515124 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr120032-1.c @@ -0,0 +1,22 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mlzcnt" } */ + +unsigned int +ZSTD_countLeadingZeros32_fallback(unsigned int val) +{ + static const unsigned int DeBruijnClz[32] + = { 0, 9, 1, 10, 13, 21, 2, 29, + 11, 14, 16, 18, 22, 25, 3, 30, + 8, 12, 20, 28, 15, 17, 24, 7, + 19, 27, 23, 6, 26, 5, 4, 31}; + if (val == 0) + __builtin_abort (); + val |= val >> 1; + val |= val >> 2; + val |= val >> 4; + val |= val >> 8; + val |= val >> 16; + return 31 - DeBruijnClz[(val * 0x07C4ACDDU) >> 27]; +} + +/* { dg-final { scan-assembler "lzcnt" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr120032-2.c b/gcc/testsuite/gcc.target/i386/pr120032-2.c new file mode 100644 index 0000000..ea2ad40 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr120032-2.c @@ -0,0 +1,22 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mlzcnt" } */ + +unsigned int +ZSTD_countLeadingZeros32_fallback(unsigned int val) +{ + static const unsigned char DeBruijnClz[32] + = { 0, 9, 1, 10, 13, 21, 2, 29, + 11, 14, 16, 18, 22, 25, 3, 30, + 8, 12, 20, 28, 15, 17, 24, 7, + 19, 27, 23, 6, 26, 5, 4, 31}; + if (val == 0) + __builtin_abort (); + val |= val >> 1; + val |= val >> 2; + val |= val >> 4; + val |= val >> 8; + val |= val >> 16; + return 31 - DeBruijnClz[(val * 0x07C4ACDDU) >> 27]; +} + +/* { dg-final { scan-assembler "lzcnt" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr120032-3.c b/gcc/testsuite/gcc.target/i386/pr120032-3.c new file mode 100644 index 0000000..9523bbb --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr120032-3.c @@ -0,0 +1,20 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mlzcnt" } */ + +unsigned int +ZSTD_countLeadingZeros32_fallback(unsigned int val) +{ + static const unsigned int DeBruijnClz[32] + = { 0, 9, 1, 10, 13, 21, 2, 29, + 11, 14, 16, 18, 22, 25, 3, 30, + 8, 12, 20, 28, 15, 17, 24, 7, + 19, 27, 23, 6, 26, 5, 4, 31}; + val |= val >> 1; + val |= val >> 2; + val |= val >> 4; + val |= val >> 8; + val |= val >> 16; + return 31 - DeBruijnClz[(val * 0x07C4ACDDU) >> 27]; +} + +/* { dg-final { scan-assembler "lzcnt" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr120553.c b/gcc/testsuite/gcc.target/i386/pr120553.c new file mode 100644 index 0000000..abbf58c --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr120553.c @@ -0,0 +1,6 @@ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2" } */ + +long long foo (long long c) { return c >= 0 ? 0x400000000ll : -1ll; } + +/* { dg-final { scan-assembler "bts" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr49095-2.c b/gcc/testsuite/gcc.target/i386/pr49095-2.c new file mode 100644 index 0000000..25bc6b7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr49095-2.c @@ -0,0 +1,73 @@ +/* PR rtl-optimization/49095 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-Os -fno-shrink-wrap -masm=att -mapxf" } */ + +void foo (void *); + +int * +f1 (int *x) +{ + if (!--*x) + foo (x); + return x; +} + +int +g1 (int x) +{ + if (!--x) + foo ((void *) 0); + return x; +} + +#define F(T, OP, OPN) \ +T * \ +f##T##OPN (T *x, T y) \ +{ \ + *x OP y; \ + if (!*x) \ + foo (x); \ + return x; \ +} \ + \ +T \ +g##T##OPN (T x, T y) \ +{ \ + x OP y; \ + if (!x) \ + foo ((void *) 0); \ + return x; \ +} \ + \ +T * \ +h##T##OPN (T *x) \ +{ \ + *x OP 24; \ + if (!*x) \ + foo (x); \ + return x; \ +} \ + \ +T \ +i##T##OPN (T x, T y) \ +{ \ + x OP 24; \ + if (!x) \ + foo ((void *) 0); \ + return x; \ +} + +#define G(T) \ +F (T, +=, plus) \ +F (T, -=, minus) \ +F (T, &=, and) \ +F (T, |=, or) \ +F (T, ^=, xor) + +G (char) +G (short) +G (int) +G (long) + +/* { dg-final { scan-assembler-not "test\[lq\]" } } */ +/* { dg-final { scan-assembler-not "\\(%\[re\]di\\), %" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr79173-13.c b/gcc/testsuite/gcc.target/i386/pr79173-13.c new file mode 100644 index 0000000..7d5818b --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-13.c @@ -0,0 +1,59 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "subq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "subl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r; + unsigned long c1 = __builtin_add_overflow (x, y, &r); + unsigned long c2 = __builtin_add_overflow (r, carry_in, &r); + *carry_out = c1 + c2; + return r; +} + +static unsigned long +usubc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r; + unsigned long c1 = __builtin_sub_overflow (x, y, &r); + unsigned long c2 = __builtin_sub_overflow (r, carry_in, &r); + *carry_out = c1 + c2; + return r; +} + +void +foo (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); +} + +void +bar (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = usubc (p[0], q[0], 0, &c); + p[1] = usubc (p[1], q[1], c, &c); + p[2] = usubc (p[2], q[2], c, &c); + p[3] = usubc (p[3], q[3], c, &c); +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-14.c b/gcc/testsuite/gcc.target/i386/pr79173-14.c new file mode 100644 index 0000000..de85051 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-14.c @@ -0,0 +1,59 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "subq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "subl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, _Bool carry_in, _Bool *carry_out) +{ + unsigned long r; + _Bool c1 = __builtin_add_overflow (x, y, &r); + _Bool c2 = __builtin_add_overflow (r, carry_in, &r); + *carry_out = c1 | c2; + return r; +} + +static unsigned long +usubc (unsigned long x, unsigned long y, _Bool carry_in, _Bool *carry_out) +{ + unsigned long r; + _Bool c1 = __builtin_sub_overflow (x, y, &r); + _Bool c2 = __builtin_sub_overflow (r, carry_in, &r); + *carry_out = c1 | c2; + return r; +} + +void +foo (unsigned long *p, unsigned long *q) +{ + _Bool c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); +} + +void +bar (unsigned long *p, unsigned long *q) +{ + _Bool c; + p[0] = usubc (p[0], q[0], 0, &c); + p[1] = usubc (p[1], q[1], c, &c); + p[2] = usubc (p[2], q[2], c, &c); + p[3] = usubc (p[3], q[3], c, &c); +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-15.c b/gcc/testsuite/gcc.target/i386/pr79173-15.c new file mode 100644 index 0000000..c3017f7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-15.c @@ -0,0 +1,61 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "subq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "subl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r; + unsigned long c1 = __builtin_add_overflow (x, y, &r); + unsigned long c2 = __builtin_add_overflow (r, carry_in, &r); + *carry_out = c1 + c2; + return r; +} + +static unsigned long +usubc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r; + unsigned long c1 = __builtin_sub_overflow (x, y, &r); + unsigned long c2 = __builtin_sub_overflow (r, carry_in, &r); + *carry_out = c1 + c2; + return r; +} + +unsigned long +foo (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); + return c; +} + +unsigned long +bar (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = usubc (p[0], q[0], 0, &c); + p[1] = usubc (p[1], q[1], c, &c); + p[2] = usubc (p[2], q[2], c, &c); + p[3] = usubc (p[3], q[3], c, &c); + return c; +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-16.c b/gcc/testsuite/gcc.target/i386/pr79173-16.c new file mode 100644 index 0000000..91062fb --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-16.c @@ -0,0 +1,61 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "subq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "subl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, _Bool carry_in, _Bool *carry_out) +{ + unsigned long r; + _Bool c1 = __builtin_add_overflow (x, y, &r); + _Bool c2 = __builtin_add_overflow (r, carry_in, &r); + *carry_out = c1 ^ c2; + return r; +} + +static unsigned long +usubc (unsigned long x, unsigned long y, _Bool carry_in, _Bool *carry_out) +{ + unsigned long r; + _Bool c1 = __builtin_sub_overflow (x, y, &r); + _Bool c2 = __builtin_sub_overflow (r, carry_in, &r); + *carry_out = c1 ^ c2; + return r; +} + +_Bool +foo (unsigned long *p, unsigned long *q) +{ + _Bool c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); + return c; +} + +_Bool +bar (unsigned long *p, unsigned long *q) +{ + _Bool c; + p[0] = usubc (p[0], q[0], 0, &c); + p[1] = usubc (p[1], q[1], c, &c); + p[2] = usubc (p[2], q[2], c, &c); + p[3] = usubc (p[3], q[3], c, &c); + return c; +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-17.c b/gcc/testsuite/gcc.target/i386/pr79173-17.c new file mode 100644 index 0000000..e27f4b9 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-17.c @@ -0,0 +1,32 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r = x + y; + unsigned long c1 = r < x; + r += carry_in; + unsigned long c2 = r < carry_in; + *carry_out = c1 + c2; + return r; +} + +void +foo (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-18.c b/gcc/testsuite/gcc.target/i386/pr79173-18.c new file mode 100644 index 0000000..2728ae7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-18.c @@ -0,0 +1,33 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r = x + y; + unsigned long c1 = r < x; + r += carry_in; + unsigned long c2 = r < carry_in; + *carry_out = c1 + c2; + return r; +} + +unsigned long +foo (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); + return c; +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-60.c b/gcc/testsuite/gcc.target/riscv/arch-60.c new file mode 100644 index 0000000..ea599f2 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-60.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_svbare -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-shlocofideleg.c b/gcc/testsuite/gcc.target/riscv/arch-shlocofideleg.c new file mode 100644 index 0000000..de9f9fc --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-shlocofideleg.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_shlcofideleg -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-smcsrind.c b/gcc/testsuite/gcc.target/riscv/arch-smcsrind.c new file mode 100644 index 0000000..4d1c104 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-smcsrind.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_smcsrind -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-smrnmi.c b/gcc/testsuite/gcc.target/riscv/arch-smrnmi.c new file mode 100644 index 0000000..8e62540 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-smrnmi.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_smrnmi -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-ssccptr.c b/gcc/testsuite/gcc.target/riscv/arch-ssccptr.c new file mode 100644 index 0000000..902155a --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-ssccptr.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_ssccptr -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-sscounterenw.c b/gcc/testsuite/gcc.target/riscv/arch-sscounterenw.c new file mode 100644 index 0000000..901b6bc --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-sscounterenw.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_sscounterenw -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-sstvala.c b/gcc/testsuite/gcc.target/riscv/arch-sstvala.c new file mode 100644 index 0000000..21ea8a6 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-sstvala.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_sstvala -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-sstvecd.c b/gcc/testsuite/gcc.target/riscv/arch-sstvecd.c new file mode 100644 index 0000000..e76f7881 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-sstvecd.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_sstvecd -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-ssu64xl.c b/gcc/testsuite/gcc.target/riscv/arch-ssu64xl.c new file mode 100644 index 0000000..6e151c1 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-ssu64xl.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_ssu64xl -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/mcpu-xiangshan-kunminghu.c b/gcc/testsuite/gcc.target/riscv/mcpu-xiangshan-kunminghu.c new file mode 100644 index 0000000..e3ae65c --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/mcpu-xiangshan-kunminghu.c @@ -0,0 +1,95 @@ +/* { dg-do compile { target { rv64 } } } */ +/* { dg-skip-if "-march given" { *-*-* } { "-march=*" } } */ +/* { dg-options "-mcpu=xiangshan-kunminghu" } */ +/* XiangShan Kunminghu => rv64imafdcbvh_sdtrig_sha_shcounterenw_shgatpa + _shlcofideleg_shtvala_shvsatpa_shvstvala_shvstvecd + _smaia_smcsrind_smdbltrp_smmpm_smnpm_smrnmi_smstateen + _ssaia_ssccptr_sscofpmf_sscounterenw_sscsrind_ssdbltrp + _ssnpm_sspm_ssstateen_ssstrict_sstc_sstvala_sstvecd + _ssu64xl_supm_svade_svbare_svinval_svnapot_svpbmt + _za64rs_zacas_zawrs_zba_zbb_zbc_zbkb_zbkc_zbkx_zbs_zcb + _zcmop_zfa_zfh_zfhmin_zic64b_zicbom_zicbop_zicboz_ziccif + _zicclsm_ziccrse_zicntr_zicond_zicsr_zifencei_zihintpause + _zihpm_zimop_zkn_zknd_zkne_zknh_zksed_zksh_zkt_zvbb + _zvfh_zvfhmin_zvkt_zvl128b_zvl32b_zvl64b */ + +#if !((__riscv_xlen == 64) \ + && !defined(__riscv_32e) \ + && defined(__riscv_mul) \ + && defined(__riscv_atomic) \ + && (__riscv_flen == 64) \ + && defined(__riscv_compressed) \ + && defined(__riscv_v) \ + && defined(__riscv_zic64b) \ + && defined(__riscv_zicbom) \ + && defined(__riscv_zicbop) \ + && defined(__riscv_zicboz) \ + && defined(__riscv_ziccif) \ + && defined(__riscv_zicclsm) \ + && defined(__riscv_ziccrse) \ + && defined(__riscv_zicntr) \ + && defined(__riscv_zicond) \ + && defined(__riscv_zicsr) \ + && defined(__riscv_zifencei) \ + && defined(__riscv_zihintpause) \ + && defined(__riscv_zihpm) \ + && defined(__riscv_zimop) \ + && defined(__riscv_za64rs) \ + && defined(__riscv_zacas) \ + && defined(__riscv_zawrs) \ + && defined(__riscv_zba) \ + && defined(__riscv_zbb) \ + && defined(__riscv_zbc) \ + && defined(__riscv_zbs) \ + && defined(__riscv_zbkb) \ + && defined(__riscv_zbkc) \ + && defined(__riscv_zbkx) \ + && defined(__riscv_zcb) \ + && defined(__riscv_zcmop) \ + && defined(__riscv_zfa) \ + && defined(__riscv_zfh) \ + && defined(__riscv_zknd) \ + && defined(__riscv_zkne) \ + && defined(__riscv_zknh) \ + && defined(__riscv_zksed) \ + && defined(__riscv_zksh) \ + && defined(__riscv_zkt) \ + && defined(__riscv_zvbb) \ + && defined(__riscv_zvfh) \ + && defined(__riscv_zvkt) \ + && defined(__riscv_sdtrig) \ + && defined(__riscv_sha) \ + && defined(__riscv_shlcofideleg) \ + && defined(__riscv_smaia) \ + && defined(__riscv_smcsrind) \ + && defined(__riscv_smdbltrp) \ + && defined(__riscv_smmpm) \ + && defined(__riscv_smnpm) \ + && defined(__riscv_smrnmi) \ + && defined(__riscv_smstateen) \ + && defined(__riscv_ssaia) \ + && defined(__riscv_ssccptr) \ + && defined(__riscv_sscofpmf) \ + && defined(__riscv_sscounterenw) \ + && defined(__riscv_sscsrind) \ + && defined(__riscv_ssdbltrp) \ + && defined(__riscv_ssnpm) \ + && defined(__riscv_sspm) \ + && defined(__riscv_ssstrict) \ + && defined(__riscv_sstc) \ + && defined(__riscv_sstvala) \ + && defined(__riscv_sstvecd) \ + && defined(__riscv_ssu64xl) \ + && defined(__riscv_supm) \ + && defined(__riscv_svade) \ + && defined(__riscv_svbare) \ + && defined(__riscv_svinval) \ + && defined(__riscv_svnapot) \ + && defined(__riscv_svpbmt)) +#error "unexpected arch" +#endif + +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.target/riscv/nozicond-1.c b/gcc/testsuite/gcc.target/riscv/nozicond-1.c new file mode 100644 index 0000000..35ab6fe --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/nozicond-1.c @@ -0,0 +1,11 @@ +/* { dg-do compile { target { rv64 } } } */ +/* { dg-additional-options "-march=rv64gc_zicond -mabi=lp64d -mbranch-cost=4" } */ +/* { dg-skip-if "" { *-*-* } { "-O0" "-O1" "-Og" } } */ + + +long foo1 (long c) { return c >= 0 ? 1 : -1; } +long foo2 (long c) { return c < 0 ? -1 : 1; } + +/* { dg-final { scan-assembler-times {srai\t} 2 } } */ +/* { dg-final { scan-assembler-times {ori\t} 2 } } */ + diff --git a/gcc/testsuite/gcc.target/riscv/nozicond-2.c b/gcc/testsuite/gcc.target/riscv/nozicond-2.c new file mode 100644 index 0000000..f705253 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/nozicond-2.c @@ -0,0 +1,15 @@ +/* { dg-do compile { target { rv64 } } } */ +/* { dg-additional-options "-march=rv64gc_zicond -mabi=lp64d -mbranch-cost=4" } */ +/* { dg-skip-if "" { *-*-* } { "-O0" "-O1" "-Og" } } */ + + +long foo1 (long c) { return c < 0 ? 1 : -1; } +long foo2 (long c) { return c >= 0 ? -1 : 1; } + +/* We don't support 4->3 splitters, so this fails. We could perhaps + try to catch it in the expander as a special case rather than waiting + for combine. */ +/* { dg-final { scan-assembler-times {srai\t} 2 { xfail *-*-* } } } */ +/* { dg-final { scan-assembler-times {ori\t} 2 { xfail *-*-* } } } */ +/* { dg-final { scan-assembler-times {not\t} 2 { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.target/riscv/nozicond-3.c b/gcc/testsuite/gcc.target/riscv/nozicond-3.c new file mode 100644 index 0000000..5116742 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/nozicond-3.c @@ -0,0 +1,11 @@ +/* { dg-do compile { target { rv64 } } } */ +/* { dg-additional-options "-march=rv64gc_zicond -mabi=lp64d -mbranch-cost=4" } */ +/* { dg-skip-if "" { *-*-* } { "-O0" "-O1" "-Og" "-Os" "-Oz" } } */ + +long foo1 (long n) { return n / 4096; } + +/* { dg-final { scan-assembler-times {srai\t} 2 } } */ +/* { dg-final { scan-assembler-times {srli\t} 1 } } */ +/* { dg-final { scan-assembler-times {add\t} 1 } } */ +/* { dg-final { scan-assembler-not {czero} } } */ + diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c index 0750d8e..4685ed2 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c @@ -3,13 +3,13 @@ #include "vdiv-template.h" -/* { dg-final { scan-assembler-times {\tvdiv\.vv} 5 } } */ -/* { dg-final { scan-assembler-times {\tvdiv\.vx} 3 } } */ +/* { dg-final { scan-assembler-times {\tvdiv\.vv} 8 } } */ +/* { dg-final { scan-assembler-not {\tvdiv\.vx} } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vv} 5 } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vx} 3 } } */ -/* { dg-final { scan-assembler-times {\tvfdiv\.vv} 3 } } */ -/* { dg-final { scan-assembler-times {\tvfdiv\.vf} 3 } } */ +/* { dg-final { scan-assembler-times {\tvfdiv\.vv} 6 } } */ +/* { dg-final { scan-assembler-not {\tvfdiv\.vf} } } */ /* { dg-final { scan-tree-dump-times "\.COND_LEN_DIV" 16 "optimized" } } */ /* { dg-final { scan-tree-dump-times "\.COND_LEN_RDIV" 6 "optimized" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c index 31b2284..59c48d2 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c @@ -3,8 +3,8 @@ #include "vdiv-template.h" -/* { dg-final { scan-assembler-times {\tvdiv\.vv} 5 } } */ -/* { dg-final { scan-assembler-times {\tvdiv\.vx} 3 } } */ +/* { dg-final { scan-assembler-times {\tvdiv\.vv} 8 } } */ +/* { dg-final { scan-assembler-not {\tvdiv\.vx} } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vv} 5 } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vx} 3 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c index 6015af9..b574dc4 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c @@ -3,13 +3,13 @@ #include "vdiv-template.h" -/* { dg-final { scan-assembler-times {\tvdiv\.vv} 4 } } */ -/* { dg-final { scan-assembler-times {\tvdiv\.vx} 4 } } */ +/* { dg-final { scan-assembler-times {\tvdiv\.vv} 8 } } */ +/* { dg-final { scan-assembler-not {\tvdiv\.vx} } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vv} 4 } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vx} 4 } } */ -/* { dg-final { scan-assembler-times {\tvfdiv\.vv} 3 } } */ -/* { dg-final { scan-assembler-times {\tvfdiv\.vf} 3 } } */ +/* { dg-final { scan-assembler-times {\tvfdiv\.vv} 6 } } */ +/* { dg-final { scan-assembler-not {\tvfdiv\.vf} } } */ /* { dg-final { scan-tree-dump-times "\.COND_LEN_DIV" 16 "optimized" } } */ /* { dg-final { scan-tree-dump-times "\.COND_LEN_RDIV" 6 "optimized" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c index ccaa2f8..9b46c6b 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c @@ -3,8 +3,8 @@ #include "vdiv-template.h" -/* { dg-final { scan-assembler-times {\tvdiv\.vv} 4 } } */ -/* { dg-final { scan-assembler-times {\tvdiv\.vx} 4 } } */ +/* { dg-final { scan-assembler-times {\tvdiv\.vv} 8 } } */ +/* { dg-final { scan-assembler-not {\tvdiv\.vx} } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vv} 4 } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vx} 4 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f16.c new file mode 100644 index 0000000..821e5c5 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f16.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv_zvfh -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(_Float16, +, add) +DEF_VF_MULOP_CASE_0(_Float16, -, sub) + +/* { dg-final { scan-assembler-times {vfmadd.vf} 1 } } */ +/* { dg-final { scan-assembler-times {vfmsub.vf} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f32.c new file mode 100644 index 0000000..49b4287 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f32.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(float, +, add) +DEF_VF_MULOP_CASE_0(float, -, sub) + +/* { dg-final { scan-assembler-times {vfmadd.vf} 1 } } */ +/* { dg-final { scan-assembler-times {vfmsub.vf} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f64.c new file mode 100644 index 0000000..2bb5d89 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f64.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(double, +, add) +DEF_VF_MULOP_CASE_0(double, -, sub) + +/* { dg-final { scan-assembler-times {vfmadd.vf} 1 } } */ +/* { dg-final { scan-assembler-times {vfmsub.vf} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f16.c new file mode 100644 index 0000000..cbb43ca --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f16.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv_zvfh -mabi=lp64d --param=fpr2vr-cost=1" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(_Float16, +, add) +DEF_VF_MULOP_CASE_0(_Float16, -, sub) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f32.c new file mode 100644 index 0000000..66ff9b8 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f32.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=1" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(float, +, add) +DEF_VF_MULOP_CASE_0(float, -, sub) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f64.c new file mode 100644 index 0000000..66ff9b8 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f64.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=1" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(float, +, add) +DEF_VF_MULOP_CASE_0(float, -, sub) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f16.c new file mode 100644 index 0000000..45980f4 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f16.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv_zvfh -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(_Float16, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(_Float16, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler {vfmadd.vf} } } */ +/* { dg-final { scan-assembler {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f32.c new file mode 100644 index 0000000..c853620 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f32.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(float, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(float, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler {vfmadd.vf} } } */ +/* { dg-final { scan-assembler {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f64.c new file mode 100644 index 0000000..d38ae8b --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f64.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(double, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(double, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler {vfmadd.vf} } } */ +/* { dg-final { scan-assembler {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f16.c new file mode 100644 index 0000000..f1ca34e --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f16.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv_zvfh -mabi=lp64d --param=fpr2vr-cost=4" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(_Float16, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(_Float16, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f32.c new file mode 100644 index 0000000..6730d4b --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f32.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=4" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(float, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(float, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f64.c new file mode 100644 index 0000000..bcb6a6e --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f64.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=4" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(double, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(double, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop.h b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop.h new file mode 100644 index 0000000..5253978 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop.h @@ -0,0 +1,61 @@ +#ifndef HAVE_DEFINED_VF_MULOP_H +#define HAVE_DEFINED_VF_MULOP_H + +#include <stdint.h> + +#define DEF_VF_MULOP_CASE_0(T, OP, NAME) \ + void test_vf_mulop_##NAME##_##T##_case_0(T *restrict out, T *restrict in, \ + T x, unsigned n) { \ + for (unsigned i = 0; i < n; i++) \ + out[i] = in[i] OP out[i] * x; \ + } +#define DEF_VF_MULOP_CASE_0_WRAP(T, OP, NAME) DEF_VF_MULOP_CASE_0(T, OP, NAME) +#define RUN_VF_MULOP_CASE_0(T, NAME, out, in, x, n) \ + test_vf_mulop_##NAME##_##T##_case_0(out, in, x, n) +#define RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) \ + RUN_VF_MULOP_CASE_0(T, NAME, out, in, x, n) + +#define VF_MULOP_BODY(op) \ + out[k + 0] = in[k + 0] op tmp * out[k + 0]; \ + out[k + 1] = in[k + 1] op tmp * out[k + 1]; \ + k += 2; + +#define VF_MULOP_BODY_X4(op) \ + VF_MULOP_BODY(op) \ + VF_MULOP_BODY(op) + +#define VF_MULOP_BODY_X8(op) \ + VF_MULOP_BODY_X4(op) \ + VF_MULOP_BODY_X4(op) + +#define VF_MULOP_BODY_X16(op) \ + VF_MULOP_BODY_X8(op) \ + VF_MULOP_BODY_X8(op) + +#define VF_MULOP_BODY_X32(op) \ + VF_MULOP_BODY_X16(op) \ + VF_MULOP_BODY_X16(op) + +#define VF_MULOP_BODY_X64(op) \ + VF_MULOP_BODY_X32(op) \ + VF_MULOP_BODY_X32(op) + +#define VF_MULOP_BODY_X128(op) \ + VF_MULOP_BODY_X64(op) \ + VF_MULOP_BODY_X64(op) + +#define DEF_VF_MULOP_CASE_1(T, OP, NAME, BODY) \ + void test_vf_mulop_##NAME##_##T##_case_1(T *restrict out, T *restrict in, \ + T x, unsigned n) { \ + unsigned k = 0; \ + T tmp = x + 3; \ + \ + while (k < n) { \ + tmp = tmp * 0x3f; \ + BODY(OP) \ + } \ + } +#define DEF_VF_MULOP_CASE_1_WRAP(T, OP, NAME, BODY) \ + DEF_VF_MULOP_CASE_1(T, OP, NAME, BODY) + +#endif diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_data.h b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_data.h new file mode 100644 index 0000000..c16c1a9 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_data.h @@ -0,0 +1,413 @@ +#ifndef HAVE_DEFINED_VF_MULOP_DATA_H +#define HAVE_DEFINED_VF_MULOP_DATA_H + +#define N 16 + +#define TEST_MULOP_DATA(T, NAME) test_##T##_##NAME##_data +#define TEST_MULOP_DATA_WRAP(T, NAME) TEST_MULOP_DATA(T, NAME) + + +_Float16 TEST_MULOP_DATA(_Float16, add)[][4][N] = +{ + { + { 0.30f16 }, + { + 1.48f16, 1.48f16, 1.48f16, 1.48f16, + 0.80f16, 0.80f16, 0.80f16, 0.80f16, + 0.62f16, 0.62f16, 0.62f16, 0.62f16, + 1.18f16, 1.18f16, 1.18f16, 1.18f16, + }, + { + 1.25f16, 1.25f16, 1.25f16, 1.25f16, + 1.89f16, 1.89f16, 1.89f16, 1.89f16, + 1.57f16, 1.57f16, 1.57f16, 1.57f16, + 1.21f16, 1.21f16, 1.21f16, 1.21f16, + }, + { + 1.85f16, 1.85f16, 1.85f16, 1.85f16, + 1.37f16, 1.37f16, 1.37f16, 1.37f16, + 1.09f16, 1.09f16, 1.09f16, 1.09f16, + 1.54f16, 1.54f16, 1.54f16, 1.54f16, + } + }, + { + { -0.505f16 }, + { + -2.38f16, -2.38f16, -2.38f16, -2.38f16, + -2.06f16, -2.06f16, -2.06f16, -2.06f16, + -1.69f16, -1.69f16, -1.69f16, -1.69f16, + -1.1f16, -1.1f16, -1.1f16, -1.1f16, + }, + { + -1.77f16, -1.77f16, -1.77f16, -1.77f16, + -1.6f16, -1.6f16, -1.6f16, -1.6f16, + -1.f16, -1.f16, -1.f16, -1.f16, + -1.23f16, -1.23f16, -1.23f16, -1.23f16, + }, + { + -1.49f16, -1.49f16, -1.49f16, -1.49f16, + -1.25f16, -1.25f16, -1.25f16, -1.25f16, + -1.18f16, -1.18f16, -1.18f16, -1.18f16, + -0.479f16, -0.479f16, -0.479f16, -0.479f16, + } + }, + { + { 4.95e-04f16 }, + { + 1.4266e-05f16, 1.4266e-05f16, 1.4266e-05f16, 1.4266e-05f16, + 1.8129e-05f16, 1.8129e-05f16, 1.8129e-05f16, 1.8129e-05f16, + -8.4710e-06f16, -8.4710e-06f16, -8.4710e-06f16, -8.4710e-06f16, + 3.7876e-05f16, 3.7876e-05f16, 3.7876e-05f16, 3.7876e-05f16, + }, + { + 2.2808e-02f16, 2.2808e-02f16, 2.2808e-02f16, 2.2808e-02f16, + 3.9633e-02f16, 3.9633e-02f16, 3.9633e-02f16, 3.9633e-02f16, + 9.9657e-02f16, 9.9657e-02f16, 9.9657e-02f16, 9.9657e-02f16, + 7.7189e-02f16, 7.7189e-02f16, 7.7189e-02f16, 7.7189e-02f16, + }, + { + 2.5547e-05f16, 2.5547e-05f16, 2.5547e-05f16, 2.5547e-05f16, + 3.7732e-05f16, 3.7732e-05f16, 3.7732e-05f16, 3.7732e-05f16, + 4.0820e-05f16, 4.0820e-05f16, 4.0820e-05f16, 4.0820e-05f16, + 7.6054e-05f16, 7.6054e-05f16, 7.6054e-05f16, 7.6054e-05f16, + } + }, +}; + +float TEST_MULOP_DATA(float, add)[][4][N] = +{ + { + { 43.71f }, + { + -410.28f, -410.28f, -410.28f, -410.28f, + -276.91f, -276.91f, -276.91f, -276.91f, + -103.38f, -103.38f, -103.38f, -103.38f, + -378.24f, -378.24f, -378.24f, -378.24f, + }, + { + 9.56f, 9.56f, 9.56f, 9.56f, + 6.39f, 6.39f, 6.39f, 6.39f, + 2.40f, 2.40f, 2.40f, 2.40f, + 8.80f, 8.80f, 8.80f, 8.80f, + }, + { + 7.59f, 7.59f, 7.59f, 7.59f, + 2.40f, 2.40f, 2.40f, 2.40f, + 1.52f, 1.52f, 1.52f, 1.52f, + 6.41f, 6.41f, 6.41f, 6.41f, + } + }, + { + { 2.04f }, + { + -110.22f, -110.22f, -110.22f, -110.22f, + -25.13f, -25.13f, -25.13f, -25.13f, + -108.18f, -108.18f, -108.18f, -108.18f, + -107.14f, -107.14f, -107.14f, -107.14f, + }, + { + 64.82f, 64.82f, 64.82f, 64.82f, + 31.65f, 31.65f, 31.65f, 31.65f, + 87.32f, 87.32f, 87.32f, 87.32f, + 58.70f, 58.70f, 58.70f, 58.70f, + }, + { + 22.01f, 22.01f, 22.01f, 22.01f, + 39.44f, 39.44f, 39.44f, 39.44f, + 69.95f, 69.95f, 69.95f, 69.95f, + 12.61f, 12.61f, 12.61f, 12.61f, + } + }, + { + { 20.35f }, + { + 881.43f, 881.43f, 881.43f, 881.43f, + 3300.17f, 3300.17f, 3300.17f, 3300.17f, + 5217.85f, 5217.85f, 5217.85f, 5217.85f, + 66.57f, 66.57f, 66.57f, 66.57f, + }, + { + 64.82f, 64.82f, 64.82f, 64.82f, + 31.65f, 31.65f, 31.65f, 31.65f, + 87.32f, 87.32f, 87.32f, 87.32f, + 58.70f, 58.70f, 58.70f, 58.70f, + }, + { + 2200.52f, 2200.52f, 2200.52f, 2200.52f, + 3944.25f, 3944.25f, 3944.25f, 3944.25f, + 6994.81f, 6994.81f, 6994.81f, 6994.81f, + 1261.12f, 1261.12f, 1261.12f, 1261.12f, + } + }, +}; + +double TEST_MULOP_DATA(double, add)[][4][N] = +{ + { + { 1.16e+12 }, + { + 1.8757e+45, 1.8757e+45, 1.8757e+45, 1.8757e+45, + 7.5140e+45, 7.5140e+45, 7.5140e+45, 7.5140e+45, + 8.2069e+45, 8.2069e+45, 8.2069e+45, 8.2069e+45, + 4.9456e+45, 4.9456e+45, 4.9456e+45, 4.9456e+45, + }, + { + 9.0242e+32, 9.0242e+32, 9.0242e+32, 9.0242e+32, + 3.6908e+32, 3.6908e+32, 3.6908e+32, 3.6908e+32, + 3.9202e+32, 3.9202e+32, 3.9202e+32, 3.9202e+32, + 5.0276e+32, 5.0276e+32, 5.0276e+32, 5.0276e+32, + }, + { + 2.9201e+45, 2.9201e+45, 2.9201e+45, 2.9201e+45, + 7.9411e+45, 7.9411e+45, 7.9411e+45, 7.9411e+45, + 8.6606e+45, 8.6606e+45, 8.6606e+45, 8.6606e+45, + 5.5275e+45, 5.5275e+45, 5.5275e+45, 5.5275e+45, + } + }, + { + { -7.29e+23 }, + { + -6.4993e+65, -6.4993e+65, -6.4993e+65, -6.4993e+65, + -4.6760e+65, -4.6760e+65, -4.6760e+65, -4.6760e+65, + -8.1564e+65, -8.1564e+65, -8.1564e+65, -8.1564e+65, + -8.2899e+65, -8.2899e+65, -8.2899e+65, -8.2899e+65, + }, + { + -7.7764e+41, -7.7764e+41, -7.7764e+41, -7.7764e+41, + -1.9756e+41, -1.9756e+41, -1.9756e+41, -1.9756e+41, + -4.8980e+41, -4.8980e+41, -4.8980e+41, -4.8980e+41, + -8.1062e+41, -8.1062e+41, -8.1062e+41, -8.1062e+41, + }, + { + -8.2928e+64, -8.2928e+64, -8.2928e+64, -8.2928e+64, + -3.2356e+65, -3.2356e+65, -3.2356e+65, -3.2356e+65, + -4.5850e+65, -4.5850e+65, -4.5850e+65, -4.5850e+65, + -2.3794e+65, -2.3794e+65, -2.3794e+65, -2.3794e+65, + } + }, + { + { 2.02e-03 }, + { + -1.2191e-35, -1.2191e-35, -1.2191e-35, -1.2191e-35, + -1.0471e-36, -1.0471e-36, -1.0471e-36, -1.0471e-36, + -9.7582e-36, -9.7582e-36, -9.7582e-36, -9.7582e-36, + -2.2097e-36, -2.2097e-36, -2.2097e-36, -2.2097e-36, + }, + { + 9.7703e-33, 9.7703e-33, 9.7703e-33, 9.7703e-33, + 4.1632e-33, 4.1632e-33, 4.1632e-33, 4.1632e-33, + 8.1964e-33, 8.1964e-33, 8.1964e-33, 8.1964e-33, + 4.7314e-33, 4.7314e-33, 4.7314e-33, 4.7314e-33, + }, + { + 7.5586e-36, 7.5586e-36, 7.5586e-36, 7.5586e-36, + 7.3684e-36, 7.3684e-36, 7.3684e-36, 7.3684e-36, + 6.8101e-36, 6.8101e-36, 6.8101e-36, 6.8101e-36, + 7.3543e-36, 7.3543e-36, 7.3543e-36, 7.3543e-36, + } + }, +}; + +_Float16 TEST_MULOP_DATA(_Float16, sub)[][4][N] = +{ + { + { 0.676f16 }, + { + 1.39f16, 1.39f16, 1.39f16, 1.39f16, + 1.68f16, 1.68f16, 1.68f16, 1.68f16, + 1.63f16, 1.63f16, 1.63f16, 1.63f16, + 2.12f16, 2.12f16, 2.12f16, 2.12f16, + }, + { + 1.04f16, 1.04f16, 1.04f16, 1.04f16, + 1.64f16, 1.64f16, 1.64f16, 1.64f16, + 1.95f16, 1.95f16, 1.95f16, 1.95f16, + 1.39f16, 1.39f16, 1.39f16, 1.39f16, + }, + { + 0.687f16, 0.687f16, 0.687f16, 0.687f16, + 0.568f16, 0.568f16, 0.568f16, 0.568f16, + 0.315f16, 0.315f16, 0.315f16, 0.315f16, + 1.18f16, 1.18f16, 1.18f16, 1.18f16, + } +}, + { + { -0.324f16 }, + { + -0.679f16, -0.679f16, -0.679f16, -0.679f16, + -0.992f16, -0.992f16, -0.992f16, -0.992f16, + -1.34f16, -1.34f16, -1.34f16, -1.34f16, + -0.297f16, -0.297f16, -0.297f16, -0.297f16, + }, + { + -1.96f16, -1.96f16, -1.96f16, -1.96f16, + -1.36f16, -1.36f16, -1.36f16, -1.36f16, + -1.05f16, -1.05f16, -1.05f16, -1.05f16, + -1.61f16, -1.61f16, -1.61f16, -1.61f16, + }, + { + -1.31f16, -1.31f16, -1.31f16, -1.31f16, + -1.43f16, -1.43f16, -1.43f16, -1.43f16, + -1.68f16, -1.68f16, -1.68f16, -1.68f16, + -0.82f16, -0.82f16, -0.82f16, -0.82f16, + } + }, + { + { 7.08e+01f16 }, + { + 4.49e+03f16, 4.49e+03f16, 4.49e+03f16, 4.49e+03f16, + 7.73e+03f16, 7.73e+03f16, 7.73e+03f16, 7.73e+03f16, + 8.42e+03f16, 8.42e+03f16, 8.42e+03f16, 8.42e+03f16, + 9.12e+03f16, 9.12e+03f16, 9.12e+03f16, 9.12e+03f16, + }, + { + 1.40e+01f16, 1.40e+01f16, 1.40e+01f16, 1.40e+01f16, + 6.80e+01f16, 6.80e+01f16, 6.80e+01f16, 6.80e+01f16, + 9.54e+01f16, 9.54e+01f16, 9.54e+01f16, 9.54e+01f16, + 4.49e+01f16, 4.49e+01f16, 4.49e+01f16, 4.49e+01f16, + }, + { + 3.50e+03f16, 3.50e+03f16, 3.50e+03f16, 3.50e+03f16, + 2.91e+03f16, 2.91e+03f16, 2.91e+03f16, 2.91e+03f16, + 1.66e+03f16, 1.66e+03f16, 1.66e+03f16, 1.66e+03f16, + 5.94e+03f16, 5.94e+03f16, 5.94e+03f16, 5.94e+03f16, + } + }, +}; + +float TEST_MULOP_DATA(float, sub)[][4][N] = +{ + { + {8.51f }, + { + 24.21f, 24.21f, 24.21f, 24.21f, + 40.31f, 40.31f, 40.31f, 40.31f, + 59.68f, 59.68f, 59.68f, 59.68f, + 45.42f, 45.42f, 45.42f, 45.42f, + }, + { + 1.94f, 1.94f, 1.94f, 1.94f, + 4.24f, 4.24f, 4.24f, 4.24f, + 6.48f, 6.48f, 6.48f, 6.48f, + 4.68f, 4.68f, 4.68f, 4.68f, + }, + { + 7.70f, 7.70f, 7.70f, 7.70f, + 4.23f, 4.23f, 4.23f, 4.23f, + 4.54f, 4.54f, 4.54f, 4.54f, + 5.59f, 5.59f, 5.59f, 5.59f, + }, +}, + { + { 85.14f }, + { + 1731.29f, 1731.29f, 1731.29f, 1731.29f, + 3656.53f, 3656.53f, 3656.53f, 3656.53f, + 5565.07f, 5565.07f, 5565.07f, 5565.07f, + 4042.14f, 4042.14f, 4042.14f, 4042.14f, + }, + { + 19.43f, 19.43f, 19.43f, 19.43f, + 42.45f, 42.45f, 42.45f, 42.45f, + 64.83f, 64.83f, 64.83f, 64.83f, + 46.82f, 46.82f, 46.82f, 46.82f, + }, + { + 77.02f, 77.02f, 77.02f, 77.02f, + 42.34f, 42.34f, 42.34f, 42.34f, + 45.44f, 45.44f, 45.44f, 45.44f, + 55.89f, 55.89f, 55.89f, 55.89f, + } + }, + { + { 99.01f }, + { + 6240.43f, 6240.43f, 6240.43f, 6240.43f, + 2179.23f, 2179.23f, 2179.23f, 2179.23f, + 5346.65f, 5346.65f, 5346.65f, 5346.65f, + 2649.91f, 2649.91f, 2649.91f, 2649.91f, + }, + { + 59.46f, 59.46f, 59.46f, 59.46f, + 16.96f, 16.96f, 16.96f, 16.96f, + 52.55f, 52.55f, 52.55f, 52.55f, + 24.70f, 24.70f, 24.70f, 24.70f, + }, + { + 353.30f, 353.30f, 353.30f, 353.30f, + 500.02f, 500.02f, 500.02f, 500.02f, + 143.67f, 143.67f, 143.67f, 143.67f, + 204.36f, 204.36f, 204.36f, 204.36f, + } + }, +}; + +double TEST_MULOP_DATA(double, sub)[][4][N] = +{ + { + { 80.54 }, + { + 5731.60, 5731.60, 5731.60, 5731.60, + 6682.41, 6682.41, 6682.41, 6682.41, + 7737.53, 7737.53, 7737.53, 7737.53, + 4922.68, 4922.68, 4922.68, 4922.68, + }, + { + 67.14, 67.14, 67.14, 67.14, + 78.23, 78.23, 78.23, 78.23, + 94.35, 94.35, 94.35, 94.35, + 49.68, 49.68, 49.68, 49.68, + }, + { + 324.14, 324.14, 324.14, 324.14, + 381.77, 381.77, 381.77, 381.77, + 138.58, 138.58, 138.58, 138.58, + 921.45, 921.45, 921.45, 921.45, + } + }, + { + { 8.05e+01 }, + { + 8.65e+27, 8.65e+27, 8.65e+27, 8.65e+27, + 1.01e+28, 1.01e+28, 1.01e+28, 1.01e+28, + 8.99e+27, 8.99e+27, 8.99e+27, 8.99e+27, + 1.32e+28, 1.32e+28, 1.32e+28, 1.32e+28, + }, + { + 6.71e+25, 6.71e+25, 6.71e+25, 6.71e+25, + 7.82e+25, 7.82e+25, 7.82e+25, 7.82e+25, + 9.44e+25, 9.44e+25, 9.44e+25, 9.44e+25, + 4.97e+25, 4.97e+25, 4.97e+25, 4.97e+25, + }, + { + 3.24e+27, 3.24e+27, 3.24e+27, 3.24e+27, + 3.82e+27, 3.82e+27, 3.82e+27, 3.82e+27, + 1.39e+27, 1.39e+27, 1.39e+27, 1.39e+27, + 9.21e+27, 9.21e+27, 9.21e+27, 9.21e+27, + } + }, + { + { 2.02e-03 }, + { + 2.7308e-35, 2.7308e-35, 2.7308e-35, 2.7308e-35, + 1.5784e-35, 1.5784e-35, 1.5784e-35, 1.5784e-35, + 2.3378e-35, 2.3378e-35, 2.3378e-35, 2.3378e-35, + 1.6918e-35, 1.6918e-35, 1.6918e-35, 1.6918e-35, + }, + { + 9.7703e-33, 9.7703e-33, 9.7703e-33, 9.7703e-33, + 4.1632e-33, 4.1632e-33, 4.1632e-33, 4.1632e-33, + 8.1964e-33, 8.1964e-33, 8.1964e-33, 8.1964e-33, + 4.7314e-33, 4.7314e-33, 4.7314e-33, 4.7314e-33, + }, + { + 7.5586e-36, 7.5586e-36, 7.5586e-36, 7.5586e-36, + 7.3684e-36, 7.3684e-36, 7.3684e-36, 7.3684e-36, + 6.8101e-36, 6.8101e-36, 6.8101e-36, 6.8101e-36, + 7.3543e-36, 7.3543e-36, 7.3543e-36, 7.3543e-36, + } + }, +}; + + +#endif diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_run.h b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_run.h new file mode 100644 index 0000000..bc6f483d --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_run.h @@ -0,0 +1,34 @@ +#ifndef HAVE_DEFINED_VF_MULOP_RUN_H +#define HAVE_DEFINED_VF_MULOP_RUN_H + +#include <math.h> + +#define TYPE_FABS(x, T) \ + (__builtin_types_compatible_p (T, double) ? fabs (x) : fabsf (x)) + +int +main () +{ + unsigned i, k; + + for (i = 0; i < sizeof (TEST_DATA) / sizeof (TEST_DATA[0]); i++) + { + T x = TEST_DATA[i][0][0]; + T *in = TEST_DATA[i][1]; + T *out = TEST_DATA[i][2]; + T *expect = TEST_DATA[i][3]; + + TEST_RUN (T, NAME, out, in, x, N); + + for (k = 0; k < N; k++) + { + T diff = expect[k] - out[k]; + if (TYPE_FABS (diff, T) > .01 * TYPE_FABS (expect[k], T)) + __builtin_abort (); + } + } + + return 0; +} + +#endif diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f16.c new file mode 100644 index 0000000..1bcf9e0 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f16.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T _Float16 +#define NAME add + +DEF_VF_MULOP_CASE_0_WRAP(T, +, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f32.c new file mode 100644 index 0000000..199b9ad --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f32.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T float +#define NAME add + +DEF_VF_MULOP_CASE_0_WRAP(T, +, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f64.c new file mode 100644 index 0000000..3857f58 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f64.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T double +#define NAME add + +DEF_VF_MULOP_CASE_0_WRAP(T, +, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f16.c new file mode 100644 index 0000000..671c7d8 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f16.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T _Float16 +#define NAME sub + +DEF_VF_MULOP_CASE_0_WRAP(T, -, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f32.c new file mode 100644 index 0000000..f896963 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f32.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T float +#define NAME sub + +DEF_VF_MULOP_CASE_0_WRAP(T, -, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f64.c new file mode 100644 index 0000000..b42ab1e --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f64.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T double +#define NAME sub + +DEF_VF_MULOP_CASE_0_WRAP(T, -, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c index 144d1ba..d88e76b 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-times {vadd.vx} 1 } } */ /* { dg-final { scan-assembler-times {vsub.vx} 1 } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-times {vor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vxor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vmul.vx} 1 } } */ +/* { dg-final { scan-assembler-times {vdiv.vx} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c index 74d35d1..53189c2 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-times {vadd.vx} 1 } } */ /* { dg-final { scan-assembler-times {vsub.vx} 1 } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-times {vor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vxor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vmul.vx} 1 } } */ +/* { dg-final { scan-assembler-times {vdiv.vx} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c index ac512ff..5059beb 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-times {vadd.vx} 1 } } */ /* { dg-final { scan-assembler-times {vsub.vx} 1 } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-times {vor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vxor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vmul.vx} 1 } } */ +/* { dg-final { scan-assembler-times {vdiv.vx} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c index 4f7b675..4bbe5a4 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-times {vadd.vx} 1 } } */ /* { dg-final { scan-assembler-times {vsub.vx} 1 } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-times {vor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vxor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vmul.vx} 1 } } */ +/* { dg-final { scan-assembler-times {vdiv.vx} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c index 075c8be..0437db4 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c index 595479c..95ed403 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c index 7b6fcbf..f8912a0 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c index 55fc717..3c8f915 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c index bec6b3a..f49dae4 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c index 98fce52..8f502a3 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c index 48dd57a..3277bf2 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c index 9bdce82..25ed2ad 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c index a1b24f7..1e409de 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c index 53bd744..2f242c7 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c index 73cb89d..f027bd8 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c index ec20474..c4f55b0 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c index 902ba1e..d6b05bc 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X8) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c index e57cee6..e1c043f 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c index 3b4138d..1beb914 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c index 0ad52b2..0291517 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c index 5e04050..c22c82d 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X8) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c index 13a9fe2..dc35600 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c index ca515b4..cee1e3a 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c index 70e1abc..74fd2fb 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h index c7289ac..ed8c562 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h @@ -2554,4 +2554,200 @@ int64_t TEST_BINARY_DATA(int64_t, mul)[][3][N] = }, }; +int8_t TEST_BINARY_DATA(int8_t, div)[][3][N] = +{ + { + { 1 }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + }, + { + { 127 }, + { + 127, 127, 127, 127, + -1, -1, -1, -1, + -128, -128, -128, -128, + -2, -2, -2, -2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + -1, -1, -1, -1, + 0, 0, 0, 0, + }, + }, + { + { -128 }, + { + -128, -128, -128, -128, + 1, 1, 1, 1, + 127, 127, 127, 127, + 2, 2, 2, 2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + }, + }, +}; + +int16_t TEST_BINARY_DATA(int16_t, div)[][3][N] = +{ + { + { 1 }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + }, + { + { 32767 }, + { + 32767, 32767, 32767, 32767, + -1, -1, -1, -1, + -32768, -32768, -32768, -32768, + -2, -2, -2, -2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + -1, -1, -1, -1, + 0, 0, 0, 0, + }, + }, + { + { -32768 }, + { + -32768, -32768, -32768, -32768, + 1, 1, 1, 1, + 32767, 32767, 32767, 32767, + 2, 2, 2, 2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + }, + }, +}; + +int32_t TEST_BINARY_DATA(int32_t, div)[][3][N] = +{ + { + { 1 }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + }, + { + { 2147483647 }, + { + 2147483647, 2147483647, 2147483647, 2147483647, + -1, -1, -1, -1, + -2147483648, -2147483648, -2147483648, -2147483648, + -2, -2, -2, -2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + -1, -1, -1, -1, + 0, 0, 0, 0, + }, + }, + { + { -2147483648 }, + { + -2147483648, -2147483648, -2147483648, -2147483648, + 1, 1, 1, 1, + 2147483647, 2147483647, 2147483647, 2147483647, + 2, 2, 2, 2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + }, + }, +}; + +int64_t TEST_BINARY_DATA(int64_t, div)[][3][N] = +{ + { + { 1 }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + }, + { + { 9223372036854775807ll }, + { + 9223372036854775807ll, 9223372036854775807ll, 9223372036854775807ll, 9223372036854775807ll, + -1, -1, -1, -1, + -9223372036854775808ull, -9223372036854775808ull, -9223372036854775808ull, -9223372036854775808ull, + -2, -2, -2, -2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + -1, -1, -1, -1, + 0, 0, 0, 0, + }, + }, + { + { -9223372036854775808ull }, + { + -9223372036854775808ull, -9223372036854775808ull, -9223372036854775808ull, -9223372036854775808ull, + 1, 1, 1, 1, + 9223372036854775807ll, 9223372036854775807ll, 9223372036854775807ll, 9223372036854775807ll, + 2, 2, 2, 2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + }, + }, +}; + #endif diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i16.c new file mode 100644 index 0000000..64cf31c --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i16.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "-std=c99 --param=gpr2vr-cost=0" } */ + +#include "vx_binary.h" +#include "vx_binary_data.h" + +#define T int16_t +#define NAME div + +DEF_VX_BINARY_CASE_0_WRAP(T, /, NAME) + +#define TEST_DATA TEST_BINARY_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VX_BINARY_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vx_binary_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i32.c new file mode 100644 index 0000000..2fe6623 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i32.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "-std=c99 --param=gpr2vr-cost=0" } */ + +#include "vx_binary.h" +#include "vx_binary_data.h" + +#define T int32_t +#define NAME div + +DEF_VX_BINARY_CASE_0_WRAP(T, /, NAME) + +#define TEST_DATA TEST_BINARY_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VX_BINARY_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vx_binary_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i64.c new file mode 100644 index 0000000..03dbe03 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i64.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "-std=c99 --param=gpr2vr-cost=0" } */ + +#include "vx_binary.h" +#include "vx_binary_data.h" + +#define T int64_t +#define NAME div + +DEF_VX_BINARY_CASE_0_WRAP(T, /, NAME) + +#define TEST_DATA TEST_BINARY_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VX_BINARY_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vx_binary_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i8.c new file mode 100644 index 0000000..e54e5bc --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i8.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "-std=c99 --param=gpr2vr-cost=0" } */ + +#include "vx_binary.h" +#include "vx_binary_data.h" + +#define T int8_t +#define NAME div + +DEF_VX_BINARY_CASE_0_WRAP(T, /, NAME) + +#define TEST_DATA TEST_BINARY_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VX_BINARY_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vx_binary_run.h" diff --git a/gcc/testsuite/gfortran.dg/coarray_data_2.f90 b/gcc/testsuite/gfortran.dg/coarray_data_2.f90 new file mode 100644 index 0000000..bda57f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_data_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=lib -Warray-temporaries" } +! +! PR fortran/99838 - ICE due to missing locus with data statement for coarray +! +! Contributed by Gerhard Steinmetz + +program p + type t + integer :: a + end type + type(t) :: x(3)[*] + data x%a /1, 2, 3/ ! { dg-warning "Creating array temporary" } +end diff --git a/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 b/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 index 580cb1a..bb1a3cb 100644 --- a/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 +++ b/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 @@ -58,4 +58,4 @@ program main end do end do end program main -! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "optimized" } } +! { dg-final { scan-tree-dump-not "_gfortran_matmul" "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 b/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 new file mode 100644 index 0000000..0876941 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-optimized -Wrealloc-lhs -finline-matmul-limit=1000 -O" } +! PR 66094: Check functionality for MATMUL(TRANSPOSE(A),B)) for two-dimensional arrays +program main + implicit none + integer :: in, im, icnt + integer, volatile :: ten + + ten = 10 + ! cycle through a few test cases... + do in = 2,ten + do im = 2,ten + do icnt = 2,ten + block + real, dimension(icnt,in) :: a2 + real, dimension(icnt,im) :: b2 + real, dimension(in,im) :: c2,cr + integer :: i,j,k + call random_number(a2) + call random_number(b2) + c2 = 0 + do i=1,size(a2,2) + do j=1, size(b2,2) + do k=1, size(a2,1) + c2(i,j) = c2(i,j) + a2(k,i) * b2(k,j) + end do + end do + end do + cr = matmul(transpose(a2), b2) + if (any(abs(c2-cr) > 1e-4)) STOP 7 + end block + end do + end do + end do +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/save_8.f90 b/gcc/testsuite/gfortran.dg/save_8.f90 new file mode 100644 index 0000000..8e9198c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/save_8.f90 @@ -0,0 +1,13 @@ +!{ dg-do run } + +! Check PR120483 is fixed. +! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> +! and Peter Güntert <peter@guentert.com> + +program save_8 + implicit none + character(len=:), allocatable, save :: s1 + s1 = 'ABC' + if (s1(3:3) /= 'C') stop 1 +end program save_8 + diff --git a/gcc/testsuite/gm2/iso/fail/badreturn.mod b/gcc/testsuite/gm2/iso/fail/badreturn.mod new file mode 100644 index 0000000..5417961 --- /dev/null +++ b/gcc/testsuite/gm2/iso/fail/badreturn.mod @@ -0,0 +1,5 @@ +MODULE badreturn ; + +BEGIN + RETURN 0 +END badreturn.
\ No newline at end of file diff --git a/gcc/testsuite/gm2/iso/fail/badreturn2.mod b/gcc/testsuite/gm2/iso/fail/badreturn2.mod new file mode 100644 index 0000000..a4b9008 --- /dev/null +++ b/gcc/testsuite/gm2/iso/fail/badreturn2.mod @@ -0,0 +1,12 @@ +MODULE badreturn2 ; + + +PROCEDURE foo ; +BEGIN + RETURN 0 +END foo ; + + +BEGIN + foo +END badreturn2. diff --git a/gcc/testsuite/gm2/iso/pass/modulereturn.mod b/gcc/testsuite/gm2/iso/pass/modulereturn.mod new file mode 100644 index 0000000..b39947d --- /dev/null +++ b/gcc/testsuite/gm2/iso/pass/modulereturn.mod @@ -0,0 +1,5 @@ +MODULE modulereturn ; + +BEGIN + RETURN +END modulereturn. diff --git a/gcc/testsuite/gm2/iso/pass/modulereturn2.mod b/gcc/testsuite/gm2/iso/pass/modulereturn2.mod new file mode 100644 index 0000000..934cfae --- /dev/null +++ b/gcc/testsuite/gm2/iso/pass/modulereturn2.mod @@ -0,0 +1,10 @@ +MODULE modulereturn2 ; + + +BEGIN + RETURN +EXCEPT + RETURN +FINALLY + RETURN +END modulereturn2. diff --git a/gcc/testsuite/gnat.dg/specs/aggr7.ads b/gcc/testsuite/gnat.dg/specs/aggr7.ads new file mode 100644 index 0000000..06980b3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/aggr7.ads @@ -0,0 +1,11 @@ +-- { dg-do compile } + +package Aggr7 is + + type Arr is array (Integer range <>) of Boolean; + + Data : constant Arr := (False, True); + + function Get_Data return Arr is (Data); + +end Aggr7; diff --git a/gcc/testsuite/gnat.dg/specs/opt7.ads b/gcc/testsuite/gnat.dg/specs/opt7.ads new file mode 100644 index 0000000..ee151f0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7.ads @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatn" } + +with Opt7_Pkg; use Opt7_Pkg; + +package Opt7 is + + type Rec is record + E : Enum; + end record; + + function Image (R : Rec) return String is + (if R.E = A then Image (R.E) else ""); + +end Opt7; diff --git a/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb b/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb new file mode 100644 index 0000000..1c9d79b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb @@ -0,0 +1,15 @@ +package body Opt7_Pkg is + + type Constant_String_Access is access constant String; + + type Enum_Name is array (Enum) of Constant_String_Access; + + Enum_Name_Table : constant Enum_Name := + (A => new String'("A"), B => new String'("B")); + + function Image (E : Enum) return String is + begin + return Enum_Name_Table (E).all; + end Image; + +end Opt7_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads b/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads new file mode 100644 index 0000000..2dd271b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads @@ -0,0 +1,9 @@ +-- { dg-excess-errors "no code generated" } + +package Opt7_Pkg is + + type Enum is (A, B); + + function Image (E : Enum) return String with Inline; + +end Opt7_Pkg; diff --git a/gcc/tree-eh.cc b/gcc/tree-eh.cc index a4d5995..8cc81eb 100644 --- a/gcc/tree-eh.cc +++ b/gcc/tree-eh.cc @@ -2538,6 +2538,13 @@ operation_could_trap_helper_p (enum tree_code op, /* Constructing an object cannot trap. */ return false; + case FIX_TRUNC_EXPR: + case VEC_PACK_FIX_TRUNC_EXPR: + case VEC_UNPACK_FIX_TRUNC_HI_EXPR: + case VEC_UNPACK_FIX_TRUNC_LO_EXPR: + /* The FIX_TRUNC family are always potentially trapping. */ + return flag_trapping_math; + case COND_EXPR: case VEC_COND_EXPR: /* Whether *COND_EXPR can trap depends on whether the diff --git a/gcc/tree-sra.cc b/gcc/tree-sra.cc index 4b6daf7..23236fc 100644 --- a/gcc/tree-sra.cc +++ b/gcc/tree-sra.cc @@ -3760,7 +3760,7 @@ sra_get_max_scalarization_size (void) /* If the user didn't set PARAM_SRA_MAX_SCALARIZATION_SIZE_<...>, fall back to a target default. */ unsigned HOST_WIDE_INT max_scalarization_size - = get_move_ratio (optimize_speed_p) * UNITS_PER_WORD; + = get_move_ratio (optimize_speed_p) * MOVE_MAX; if (optimize_speed_p) { diff --git a/gcc/tree-ssa-ccp.cc b/gcc/tree-ssa-ccp.cc index 8d2cbb3..13cd81d 100644 --- a/gcc/tree-ssa-ccp.cc +++ b/gcc/tree-ssa-ccp.cc @@ -298,7 +298,7 @@ get_default_value (tree var) { val.lattice_val = VARYING; val.mask = -1; - if (flag_tree_bit_ccp) + if (flag_tree_bit_ccp && !VECTOR_TYPE_P (TREE_TYPE (var))) { wide_int nonzero_bits = get_nonzero_bits (var); tree value; @@ -2491,11 +2491,11 @@ evaluate_stmt (gimple *stmt) is_constant = (val.lattice_val == CONSTANT); } + tree lhs = gimple_get_lhs (stmt); if (flag_tree_bit_ccp + && lhs && TREE_CODE (lhs) == SSA_NAME && !VECTOR_TYPE_P (TREE_TYPE (lhs)) && ((is_constant && TREE_CODE (val.value) == INTEGER_CST) - || !is_constant) - && gimple_get_lhs (stmt) - && TREE_CODE (gimple_get_lhs (stmt)) == SSA_NAME) + || !is_constant)) { tree lhs = gimple_get_lhs (stmt); wide_int nonzero_bits = get_nonzero_bits (lhs); @@ -2567,7 +2567,12 @@ insert_clobber_before_stack_restore (tree saved_val, tree var, { clobber = build_clobber (TREE_TYPE (var), CLOBBER_STORAGE_END); clobber_stmt = gimple_build_assign (var, clobber); - + /* Manually update the vdef/vuse here. */ + gimple_set_vuse (clobber_stmt, gimple_vuse (stmt)); + gimple_set_vdef (clobber_stmt, make_ssa_name (gimple_vop (cfun))); + gimple_set_vuse (stmt, gimple_vdef (clobber_stmt)); + SSA_NAME_DEF_STMT (gimple_vdef (clobber_stmt)) = clobber_stmt; + update_stmt (stmt); i = gsi_for_stmt (stmt); gsi_insert_before (&i, clobber_stmt, GSI_SAME_STMT); } @@ -3020,7 +3025,7 @@ do_ssa_ccp (bool nonzero_p) ccp_propagate.ssa_propagate (); if (ccp_finalize (nonzero_p || flag_ipa_bit_cp)) { - todo = (TODO_cleanup_cfg | TODO_update_ssa); + todo = TODO_cleanup_cfg; /* ccp_finalize does not preserve loop-closed ssa. */ loops_state_clear (LOOP_CLOSED_SSA); diff --git a/gcc/tree-ssa-forwprop.cc b/gcc/tree-ssa-forwprop.cc index 75901ec..43b1c9d 100644 --- a/gcc/tree-ssa-forwprop.cc +++ b/gcc/tree-ssa-forwprop.cc @@ -1343,6 +1343,88 @@ optimize_memcpy_to_memset (gimple_stmt_iterator *gsip, tree dest, tree src, tree } return true; } +/* Optimizes + a = c; + b = a; + into + a = c; + b = c; + GSIP is the second statement and SRC is the common + between the statements. +*/ +static bool +optimize_agr_copyprop (gimple_stmt_iterator *gsip) +{ + gimple *stmt = gsi_stmt (*gsip); + if (gimple_has_volatile_ops (stmt)) + return false; + + tree dest = gimple_assign_lhs (stmt); + tree src = gimple_assign_rhs1 (stmt); + /* If the statement is `src = src;` then ignore it. */ + if (operand_equal_p (dest, src, 0)) + return false; + + tree vuse = gimple_vuse (stmt); + /* If the vuse is the default definition, then there is no store beforehand. */ + if (SSA_NAME_IS_DEFAULT_DEF (vuse)) + return false; + gimple *defstmt = SSA_NAME_DEF_STMT (vuse); + if (!gimple_assign_load_p (defstmt) + || !gimple_store_p (defstmt)) + return false; + if (gimple_has_volatile_ops (defstmt)) + return false; + + tree dest2 = gimple_assign_lhs (defstmt); + tree src2 = gimple_assign_rhs1 (defstmt); + + /* If the original store is `src2 = src2;` skip over it. */ + if (operand_equal_p (src2, dest2, 0)) + return false; + if (!operand_equal_p (src, dest2, 0)) + return false; + + + /* For 2 memory refences and using a temporary to do the copy, + don't remove the temporary as the 2 memory references might overlap. + Note t does not need to be decl as it could be field. + See PR 22237 for full details. + E.g. + t = *a; + *b = t; + Cannot be convert into + t = *a; + *b = *a; + Though the following is allowed to be done: + t = *a; + *a = t; + And convert it into: + t = *a; + *a = *a; + */ + if (!operand_equal_p (src2, dest, 0) + && !DECL_P (dest) && !DECL_P (src2)) + return false; + + if (dump_file && (dump_flags & TDF_DETAILS)) + { + fprintf (dump_file, "Simplified\n "); + print_gimple_stmt (dump_file, stmt, 0, dump_flags); + fprintf (dump_file, "after previous\n "); + print_gimple_stmt (dump_file, defstmt, 0, dump_flags); + } + gimple_assign_set_rhs_from_tree (gsip, unshare_expr (src2)); + update_stmt (stmt); + + if (dump_file && (dump_flags & TDF_DETAILS)) + { + fprintf (dump_file, "into\n "); + print_gimple_stmt (dump_file, stmt, 0, dump_flags); + } + statistics_counter_event (cfun, "copy prop for aggregate", 1); + return true; +} /* *GSI_P is a GIMPLE_CALL to a builtin function. Optimize @@ -2426,17 +2508,16 @@ simplify_rotate (gimple_stmt_iterator *gsi) } -/* Check whether an array contains a valid ctz table. */ +/* Check whether an array contains a valid table according to VALIDATE_FN. */ +template<typename ValidateFn> static bool -check_ctz_array (tree ctor, unsigned HOST_WIDE_INT mulc, - HOST_WIDE_INT &zero_val, unsigned shift, unsigned bits) +check_table_array (tree ctor, HOST_WIDE_INT &zero_val, unsigned bits, + ValidateFn validate_fn) { tree elt, idx; - unsigned HOST_WIDE_INT i, mask, raw_idx = 0; + unsigned HOST_WIDE_INT i, raw_idx = 0; unsigned matched = 0; - mask = ((HOST_WIDE_INT_1U << (bits - shift)) - 1) << shift; - zero_val = 0; FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), i, idx, elt) @@ -2476,7 +2557,7 @@ check_ctz_array (tree ctor, unsigned HOST_WIDE_INT mulc, matched++; } - if (val >= 0 && val < bits && (((mulc << val) & mask) >> shift) == index) + if (val >= 0 && val < bits && validate_fn (val, index)) matched++; if (matched > bits) @@ -2486,48 +2567,86 @@ check_ctz_array (tree ctor, unsigned HOST_WIDE_INT mulc, return false; } -/* Check whether a string contains a valid ctz table. */ +/* Check whether a string contains a valid table according to VALIDATE_FN. */ +template<typename ValidateFn> static bool -check_ctz_string (tree string, unsigned HOST_WIDE_INT mulc, - HOST_WIDE_INT &zero_val, unsigned shift, unsigned bits) +check_table_string (tree string, HOST_WIDE_INT &zero_val,unsigned bits, + ValidateFn validate_fn) { unsigned HOST_WIDE_INT len = TREE_STRING_LENGTH (string); - unsigned HOST_WIDE_INT mask; unsigned matched = 0; const unsigned char *p = (const unsigned char *) TREE_STRING_POINTER (string); if (len < bits || len > bits * 2) return false; - mask = ((HOST_WIDE_INT_1U << (bits - shift)) - 1) << shift; - zero_val = p[0]; for (unsigned i = 0; i < len; i++) - if (p[i] < bits && (((mulc << p[i]) & mask) >> shift) == i) + if (p[i] < bits && validate_fn (p[i], i)) matched++; return matched == bits; } -/* Recognize count trailing zeroes idiom. +/* Check whether CTOR contains a valid table according to VALIDATE_FN. */ +template<typename ValidateFn> +static bool +check_table (tree ctor, tree type, HOST_WIDE_INT &zero_val, unsigned bits, + ValidateFn validate_fn) +{ + if (TREE_CODE (ctor) == CONSTRUCTOR) + return check_table_array (ctor, zero_val, bits, validate_fn); + else if (TREE_CODE (ctor) == STRING_CST + && TYPE_PRECISION (type) == CHAR_TYPE_SIZE) + return check_table_string (ctor, zero_val, bits, validate_fn); + return false; +} + +/* Match.pd function to match the ctz expression. */ +extern bool gimple_ctz_table_index (tree, tree *, tree (*)(tree)); +extern bool gimple_clz_table_index (tree, tree *, tree (*)(tree)); + +/* Recognize count leading and trailing zeroes idioms. The canonical form is array[((x & -x) * C) >> SHIFT] where C is a magic constant which when multiplied by a power of 2 creates a unique value in the top 5 or 6 bits. This is then indexed into a table which maps it to the number of trailing zeroes. Array[0] is returned so the caller can emit an appropriate sequence depending on whether ctz (0) is defined on the target. */ + static bool -optimize_count_trailing_zeroes (tree array_ref, tree x, tree mulc, - tree tshift, HOST_WIDE_INT &zero_val) +simplify_count_zeroes (gimple_stmt_iterator *gsi) { - tree type = TREE_TYPE (array_ref); - tree array = TREE_OPERAND (array_ref, 0); + gimple *stmt = gsi_stmt (*gsi); + tree array_ref = gimple_assign_rhs1 (stmt); + tree res_ops[3]; - gcc_assert (TREE_CODE (mulc) == INTEGER_CST); - gcc_assert (TREE_CODE (tshift) == INTEGER_CST); + gcc_checking_assert (TREE_CODE (array_ref) == ARRAY_REF); - tree input_type = TREE_TYPE (x); + internal_fn fn = IFN_LAST; + /* For CTZ we recognize ((x & -x) * C) >> SHIFT where the array data + represents the number of trailing zeros. */ + if (gimple_ctz_table_index (TREE_OPERAND (array_ref, 1), &res_ops[0], NULL)) + fn = IFN_CTZ; + /* For CLZ we recognize + x |= x >> 1; + x |= x >> 2; + x |= x >> 4; + x |= x >> 8; + x |= x >> 16; + (x * C) >> SHIFT + where 31 minus the array data represents the number of leading zeros. */ + else if (gimple_clz_table_index (TREE_OPERAND (array_ref, 1), &res_ops[0], + NULL)) + fn = IFN_CLZ; + else + return false; + + HOST_WIDE_INT zero_val; + tree type = TREE_TYPE (array_ref); + tree array = TREE_OPERAND (array_ref, 0); + tree input_type = TREE_TYPE (res_ops[0]); unsigned input_bits = tree_to_shwi (TYPE_SIZE (input_type)); /* Check the array element type is not wider than 32 bits and the input is @@ -2537,7 +2656,7 @@ optimize_count_trailing_zeroes (tree array_ref, tree x, tree mulc, if (input_bits != 32 && input_bits != 64) return false; - if (!direct_internal_fn_supported_p (IFN_CTZ, input_type, OPTIMIZE_FOR_BOTH)) + if (!direct_internal_fn_supported_p (fn, input_type, OPTIMIZE_FOR_BOTH)) return false; /* Check the lower bound of the array is zero. */ @@ -2545,102 +2664,127 @@ optimize_count_trailing_zeroes (tree array_ref, tree x, tree mulc, if (!low || !integer_zerop (low)) return false; - unsigned shiftval = tree_to_shwi (tshift); - /* Check the shift extracts the top 5..7 bits. */ + unsigned shiftval = tree_to_shwi (res_ops[2]); if (shiftval < input_bits - 7 || shiftval > input_bits - 5) return false; tree ctor = ctor_for_folding (array); if (!ctor) return false; - - unsigned HOST_WIDE_INT val = tree_to_uhwi (mulc); - - if (TREE_CODE (ctor) == CONSTRUCTOR) - return check_ctz_array (ctor, val, zero_val, shiftval, input_bits); - - if (TREE_CODE (ctor) == STRING_CST - && TYPE_PRECISION (type) == CHAR_TYPE_SIZE) - return check_ctz_string (ctor, val, zero_val, shiftval, input_bits); - - return false; -} - -/* Match.pd function to match the ctz expression. */ -extern bool gimple_ctz_table_index (tree, tree *, tree (*)(tree)); - -static bool -simplify_count_trailing_zeroes (gimple_stmt_iterator *gsi) -{ - gimple *stmt = gsi_stmt (*gsi); - tree array_ref = gimple_assign_rhs1 (stmt); - tree res_ops[3]; - HOST_WIDE_INT zero_val; - - gcc_checking_assert (TREE_CODE (array_ref) == ARRAY_REF); - - if (!gimple_ctz_table_index (TREE_OPERAND (array_ref, 1), &res_ops[0], NULL)) - return false; - - if (optimize_count_trailing_zeroes (array_ref, res_ops[0], - res_ops[1], res_ops[2], zero_val)) + unsigned HOST_WIDE_INT mulval = tree_to_uhwi (res_ops[1]); + if (fn == IFN_CTZ) { - tree type = TREE_TYPE (res_ops[0]); - HOST_WIDE_INT ctz_val = 0; - HOST_WIDE_INT type_size = tree_to_shwi (TYPE_SIZE (type)); - bool zero_ok - = CTZ_DEFINED_VALUE_AT_ZERO (SCALAR_INT_TYPE_MODE (type), ctz_val) == 2; - int nargs = 2; - - /* If the input value can't be zero, don't special case ctz (0). */ - if (tree_expr_nonzero_p (res_ops[0])) + auto checkfn = [&](unsigned data, unsigned i) -> bool { - zero_ok = true; - zero_val = 0; - ctz_val = 0; - nargs = 1; - } - - /* Skip if there is no value defined at zero, or if we can't easily - return the correct value for zero. */ - if (!zero_ok) + unsigned HOST_WIDE_INT mask + = ((HOST_WIDE_INT_1U << (input_bits - shiftval)) - 1) << shiftval; + return (((mulval << data) & mask) >> shiftval) == i; + }; + if (!check_table (ctor, type, zero_val, input_bits, checkfn)) return false; - if (zero_val != ctz_val && !(zero_val == 0 && ctz_val == type_size)) - return false; - - gimple_seq seq = NULL; - gimple *g; - gcall *call - = gimple_build_call_internal (IFN_CTZ, nargs, res_ops[0], - nargs == 1 ? NULL_TREE - : build_int_cst (integer_type_node, - ctz_val)); - gimple_set_location (call, gimple_location (stmt)); - gimple_set_lhs (call, make_ssa_name (integer_type_node)); - gimple_seq_add_stmt (&seq, call); - - tree prev_lhs = gimple_call_lhs (call); - - /* Emit ctz (x) & 31 if ctz (0) is 32 but we need to return 0. */ - if (zero_val == 0 && ctz_val == type_size) + } + else if (fn == IFN_CLZ) + { + auto checkfn = [&](unsigned data, unsigned i) -> bool { - g = gimple_build_assign (make_ssa_name (integer_type_node), - BIT_AND_EXPR, prev_lhs, - build_int_cst (integer_type_node, - type_size - 1)); - gimple_set_location (g, gimple_location (stmt)); - gimple_seq_add_stmt (&seq, g); - prev_lhs = gimple_assign_lhs (g); - } + unsigned HOST_WIDE_INT mask + = ((HOST_WIDE_INT_1U << (input_bits - shiftval)) - 1) << shiftval; + return (((((HOST_WIDE_INT_1U << (data + 1)) - 1) * mulval) & mask) + >> shiftval) == i; + }; + if (!check_table (ctor, type, zero_val, input_bits, checkfn)) + return false; + } - g = gimple_build_assign (gimple_assign_lhs (stmt), NOP_EXPR, prev_lhs); + HOST_WIDE_INT ctz_val = -1; + bool zero_ok; + if (fn == IFN_CTZ) + { + ctz_val = 0; + zero_ok = CTZ_DEFINED_VALUE_AT_ZERO (SCALAR_INT_TYPE_MODE (input_type), + ctz_val) == 2; + } + else if (fn == IFN_CLZ) + { + ctz_val = 32; + zero_ok = CLZ_DEFINED_VALUE_AT_ZERO (SCALAR_INT_TYPE_MODE (input_type), + ctz_val) == 2; + zero_val = input_bits - 1 - zero_val; + } + int nargs = 2; + + /* If the input value can't be zero, don't special case ctz (0). */ + range_query *q = get_range_query (cfun); + if (q == get_global_range_query ()) + q = enable_ranger (cfun); + int_range_max vr; + if (q->range_of_expr (vr, res_ops[0], stmt) + && !range_includes_zero_p (vr)) + { + zero_ok = true; + zero_val = 0; + ctz_val = 0; + nargs = 1; + } + + gimple_seq seq = NULL; + gimple *g; + gcall *call = gimple_build_call_internal (fn, nargs, res_ops[0], + nargs == 1 ? NULL_TREE + : build_int_cst (integer_type_node, + ctz_val)); + gimple_set_location (call, gimple_location (stmt)); + gimple_set_lhs (call, make_ssa_name (integer_type_node)); + gimple_seq_add_stmt (&seq, call); + + tree prev_lhs = gimple_call_lhs (call); + if (fn == IFN_CLZ) + { + g = gimple_build_assign (make_ssa_name (integer_type_node), + MINUS_EXPR, + build_int_cst (integer_type_node, + input_bits - 1), + prev_lhs); + gimple_set_location (g, gimple_location (stmt)); gimple_seq_add_stmt (&seq, g); - gsi_replace_with_seq (gsi, seq, true); - return true; + prev_lhs = gimple_assign_lhs (g); } - return false; + if (zero_ok && zero_val == ctz_val) + ; + /* Emit ctz (x) & 31 if ctz (0) is 32 but we need to return 0. */ + else if (zero_ok && zero_val == 0 && ctz_val == input_bits) + { + g = gimple_build_assign (make_ssa_name (integer_type_node), + BIT_AND_EXPR, prev_lhs, + build_int_cst (integer_type_node, + input_bits - 1)); + gimple_set_location (g, gimple_location (stmt)); + gimple_seq_add_stmt (&seq, g); + prev_lhs = gimple_assign_lhs (g); + } + /* As fallback emit a conditional move. */ + else + { + g = gimple_build_assign (make_ssa_name (boolean_type_node), EQ_EXPR, + res_ops[0], build_zero_cst (input_type)); + gimple_set_location (g, gimple_location (stmt)); + gimple_seq_add_stmt (&seq, g); + tree cond = gimple_assign_lhs (g); + g = gimple_build_assign (make_ssa_name (integer_type_node), + COND_EXPR, cond, + build_int_cst (integer_type_node, zero_val), + prev_lhs); + gimple_set_location (g, gimple_location (stmt)); + gimple_seq_add_stmt (&seq, g); + prev_lhs = gimple_assign_lhs (g); + } + + g = gimple_build_assign (gimple_assign_lhs (stmt), NOP_EXPR, prev_lhs); + gimple_seq_add_stmt (&seq, g); + gsi_replace_with_seq (gsi, seq, true); + return true; } @@ -4724,6 +4868,11 @@ pass_forwprop::execute (function *fun) changed = true; break; } + if (optimize_agr_copyprop (&gsi)) + { + changed = true; + break; + } } if (TREE_CODE_CLASS (code) == tcc_comparison) @@ -4750,7 +4899,7 @@ pass_forwprop::execute (function *fun) && TREE_CODE (TREE_TYPE (rhs1)) == VECTOR_TYPE) changed |= simplify_vector_constructor (&gsi); else if (code == ARRAY_REF) - changed |= simplify_count_trailing_zeroes (&gsi); + changed |= simplify_count_zeroes (&gsi); break; } diff --git a/gcc/tree-ssanames.cc b/gcc/tree-ssanames.cc index fd2abfe..b6ca880 100644 --- a/gcc/tree-ssanames.cc +++ b/gcc/tree-ssanames.cc @@ -508,6 +508,14 @@ get_nonzero_bits_1 (const_tree name) /* Use element_precision instead of TYPE_PRECISION so complex and vector types get a non-zero precision. */ unsigned int precision = element_precision (TREE_TYPE (name)); + + if (VECTOR_TYPE_P (TREE_TYPE (name))) + { + tree elem = uniform_vector_p (name); + if (elem) + return get_nonzero_bits_1 (elem); + } + if (TREE_CODE (name) != SSA_NAME) return wi::shwi (-1, precision); diff --git a/gcc/tree-vect-data-refs.cc b/gcc/tree-vect-data-refs.cc index f2deb75..036903a 100644 --- a/gcc/tree-vect-data-refs.cc +++ b/gcc/tree-vect-data-refs.cc @@ -3685,7 +3685,7 @@ vect_analyze_data_ref_accesses (vec_info *vinfo, /* For datarefs with big gap, it's better to split them into different groups. .i.e a[0], a[1], a[2], .. a[7], a[100], a[101],..., a[107] */ - if ((unsigned HOST_WIDE_INT)(init_b - init_prev) * tree_to_uhwi (szb) + if ((unsigned HOST_WIDE_INT)(init_b - init_prev) > MAX_BITSIZE_MODE_ANY_MODE / BITS_PER_UNIT) break; @@ -7249,7 +7249,8 @@ vect_can_force_dr_alignment_p (const_tree decl, poly_uint64 alignment) return false; if (decl_in_symtab_p (decl) - && !symtab_node::get (decl)->can_increase_alignment_p ()) + && (!symtab_node::get (decl) + || !symtab_node::get (decl)->can_increase_alignment_p ())) return false; if (TREE_STATIC (decl)) diff --git a/gcc/var-tracking.cc b/gcc/var-tracking.cc index d70ed02..8732c3b 100644 --- a/gcc/var-tracking.cc +++ b/gcc/var-tracking.cc @@ -6273,7 +6273,7 @@ prepare_call_arguments (basic_block bb, rtx_insn *insn) if (SYMBOL_REF_DECL (symbol)) fndecl = SYMBOL_REF_DECL (symbol); } - if (fndecl == NULL_TREE) + if (fndecl == NULL_TREE && MEM_P (XEXP (call, 0))) fndecl = MEM_EXPR (XEXP (call, 0)); if (fndecl && TREE_CODE (TREE_TYPE (fndecl)) != FUNCTION_TYPE diff --git a/libgcobol/ChangeLog b/libgcobol/ChangeLog index 4293598..f853c51 100644 --- a/libgcobol/ChangeLog +++ b/libgcobol/ChangeLog @@ -1,3 +1,274 @@ +2025-06-05 Robert Dubner <rdubner@symas.com> + + PR cobol/119975 + * configure.ac: AC_CHECK_LIB(rt, clock_gettime). + * config.h.in: Likewise. + * configure: Likewise. + * gfileio.cc: Remove in-line cppcheck-suppress. + * intrinsic.cc (timespec_to_string): Use guarded clock_gettime(). + (__gg__current_date): Likewise. + (__gg__seconds_past_midnight): Likewise. + (__gg__formatted_current_date): Likewise. + (__gg__random): Likewise. + (__gg__random_next): Likewise. + (__gg__when_compiled): Likewise. + * libgcobol.cc (cobol_time): Likewise. + (get_time_nanoseconds): Likewise. + (__gg__clock_gettime): Likewise. + (__gg__get_date_hhmmssff): Likewise. + * libgcobol.h (__gg__clock_gettime): Likewise. + (struct cbl_timespec): Likewise. + +2025-06-04 Robert Dubner <rdubner@symas.com> + + PR cobol/119323 + * charmaps.cc (__gg__raw_to_ascii): Eliminate cppcheck warnings. + (__gg__raw_to_ebcdic): Likewise. + (__gg__ebcdic_to_console): Likewise. + (__gg__console_to_ascii): Likewise. + (__gg__console_to_ebcdic): Likewise. + * common-defs.h (struct cbl_declarative_t): Likewise. + * gfileio.cc (get_filename): Likewise. + (max_value): Likewise. + (relative_file_delete_varying): Likewise. + (relative_file_delete): Likewise. + (read_an_indexed_record): Likewise. + (position_state_restore): Likewise. + (indexed_file_delete): Likewise. + (indexed_file_start): Likewise. + (sequential_file_rewrite): Likewise. + (relative_file_write_varying): Likewise. + (relative_file_write): Likewise. + (sequential_file_write): Likewise. + (indexed_file_write): Likewise. + (__io__file_write): Likewise. + (line_sequential_file_read): Likewise. + (indexed_file_read): Likewise. + (file_indexed_open): Likewise. + (__gg__file_reopen): Likewise. + * gmath.cc (conditional_stash): Likewise. + (__gg__pow): Likewise. + (multiply_int256_by_int64): Likewise. + (add_int256_to_int256): Likewise. + (divide_int256_by_int64): Likewise. + (squeeze_int256): Likewise. + (get_int256_from_qualified_field): Likewise. + (__gg__add_fixed_phase1): Likewise. + (__gg__addf1_fixed_phase2): Likewise. + (__gg__fixed_phase2_assign_to_c): Likewise. + (__gg__add_float_phase1): Likewise. + (__gg__addf1_float_phase2): Likewise. + (__gg__float_phase2_assign_to_c): Likewise. + (__gg__addf3): Likewise. + (__gg__subtractf1_fixed_phase2): Likewise. + (__gg__subtractf2_fixed_phase1): Likewise. + (__gg__subtractf1_float_phase2): Likewise. + (__gg__subtractf2_float_phase1): Likewise. + (__gg__subtractf3): Likewise. + (__gg__multiplyf1_phase1): Likewise. + (multiply_int128_by_int128): Likewise. + (__gg__multiplyf1_phase2): Likewise. + (__gg__multiplyf2): Likewise. + (shift_in_place128): Likewise. + (divide_int128_by_int128): Likewise. + (__gg__dividef1_phase2): Likewise. + (__gg__dividef23): Likewise. + (__gg__dividef45): Likewise. + * intrinsic.cc (struct input_state): Likewise. + (get_value_as_double_from_qualified_field): Likewise. + (kahan_summation): Likewise. + (variance): Likewise. + (get_all_time): Likewise. + (populate_ctm_from_date): Likewise. + (populate_ctm_from_time): Likewise. + (ftime_replace): Likewise. + (__gg__abs): Likewise. + (__gg__acos): Likewise. + (__gg__annuity): Likewise. + (__gg__asin): Likewise. + (__gg__atan): Likewise. + (__gg__byte_length): Likewise. + (__gg__char): Likewise. + (__gg__combined_datetime): Likewise. + (__gg__cos): Likewise. + (__gg__date_of_integer): Likewise. + (__gg__date_to_yyyymmdd): Likewise. + (__gg__day_of_integer): Likewise. + (__gg__day_to_yyyyddd): Likewise. + (__gg__exp): Likewise. + (__gg__exp10): Likewise. + (__gg__factorial): Likewise. + (__gg__formatted_current_date): Likewise. + (__gg__formatted_date): Likewise. + (__gg__formatted_datetime): Likewise. + (__gg__formatted_time): Likewise. + (__gg__integer): Likewise. + (__gg__integer_of_date): Likewise. + (__gg__integer_of_day): Likewise. + (__gg__integer_part): Likewise. + (__gg__fraction_part): Likewise. + (__gg__log): Likewise. + (__gg__log10): Likewise. + (__gg__max): Likewise. + (__gg__lower_case): Likewise. + (__gg__median): Likewise. + (__gg__min): Likewise. + (numval): Likewise. + (numval_c): Likewise. + (__gg__numval): Likewise. + (__gg__test_numval): Likewise. + (__gg__numval_c): Likewise. + (__gg__test_numval_c): Likewise. + (__gg__ord): Likewise. + (__gg__rem): Likewise. + (__gg__trim): Likewise. + (__gg__random): Likewise. + (__gg__reverse): Likewise. + (__gg__sign): Likewise. + (__gg__sin): Likewise. + (__gg__sqrt): Likewise. + (__gg__tan): Likewise. + (__gg__test_date_yyyymmdd): Likewise. + (__gg__test_day_yyyyddd): Likewise. + (__gg__upper_case): Likewise. + (__gg__year_to_yyyy): Likewise. + (gets_int): Likewise. + (gets_year): Likewise. + (gets_month): Likewise. + (gets_day): Likewise. + (gets_day_of_week): Likewise. + (gets_day_of_year): Likewise. + (gets_week): Likewise. + (gets_hours): Likewise. + (gets_minutes): Likewise. + (gets_seconds): Likewise. + (gets_nanoseconds): Likewise. + (fill_cobol_tm): Likewise. + (__gg__test_formatted_datetime): Likewise. + (__gg__integer_of_formatted_date): Likewise. + (__gg__seconds_from_formatted_time): Likewise. + (__gg__hex_of): Likewise. + (__gg__highest_algebraic): Likewise. + (__gg__lowest_algebraic): Likewise. + (floating_format_tester): Likewise. + (__gg__numval_f): Likewise. + (__gg__test_numval_f): Likewise. + (ismatch): Likewise. + (iscasematch): Likewise. + (strstr): Likewise. + (strcasestr): Likewise. + (strlaststr): Likewise. + (strcaselaststr): Likewise. + (__gg__substitute): Likewise. + (__gg__locale_compare): Likewise. + (__gg__locale_date): Likewise. + (__gg__locale_time): Likewise. + (__gg__locale_time_from_seconds): Likewise. + * libgcobol.cc (class ec_status_t): Likewise. + (__gg__set_truncation_mode): Likewise. + (malloc): Likewise. + (__gg__mabort): Likewise. + (__gg__resize_int_p): Likewise. + (__gg__resize_treeplet): Likewise. + (var_is_refmod): Likewise. + (value_is_too_big): Likewise. + (__gg__string_to_alpha_edited_ascii): Likewise. + (int128_to_field): Likewise. + (edited_to_binary): Likewise. + (get_binary_value_local): Likewise. + (__gg__get_date_yymmdd): Likewise. + (__gg__get_date_yyyymmdd): Likewise. + (__gg__get_date_yyddd): Likewise. + (__gg__get_yyyyddd): Likewise. + (__gg__get_date_dow): Likewise. + (get_scaled_rdigits): Likewise. + (format_for_display_internal): Likewise. + (compare_88): Likewise. + (get_float128): Likewise. + (compare_field_class): Likewise. + (compare_strings): Likewise. + (__gg__compare_2): Likewise. + (__gg__sort_table): Likewise. + (init_var_both): Likewise. + (alpha_to_alpha_move_from_location): Likewise. + (alpha_to_alpha_move): Likewise. + (__gg__move): Likewise. + (__gg__move_literala): Likewise. + (__gg__sort_workfile): Likewise. + (__gg__merge_files): Likewise. + (normalize_id): Likewise. + (inspect_backward_format_1): Likewise. + (__gg__inspect_format_1): Likewise. + (inspect_backward_format_2): Likewise. + (__gg__inspect_format_2): Likewise. + (__gg__inspect_format_4): Likewise. + (move_string): Likewise. + (__gg__string): Likewise. + (display_both): Likewise. + (__gg__display_string): Likewise. + (__gg__accept): Likewise. + (__gg__binary_value_from_qualified_field): Likewise. + (__gg__float128_from_qualified_field): Likewise. + (float128_to_int128): Likewise. + (float128_to_location): Likewise. + (__gg__set_initial_switch_value): Likewise. + (is_numeric_display_numeric): Likewise. + (is_packed_numeric): Likewise. + (is_alpha_a_number): Likewise. + (__gg__classify): Likewise. + (__gg__accept_envar): Likewise. + (__gg__set_envar): Likewise. + (command_line_plan_b): Likewise. + (__gg__get_command_line): Likewise. + (__gg__set_pointer): Likewise. + (__gg__ascii_to_internal_field): Likewise. + (__gg__internal_to_console_in_place): Likewise. + (__gg__routine_to_call): Likewise. + (__gg__fetch_call_by_value_value): Likewise. + (__gg__assign_value_from_stack): Likewise. + (__gg__literaln_alpha_compare): Likewise. + (string_in): Likewise. + (__gg__unstring): Likewise. + (local_ec_type_of): Likewise. + (struct exception_descr_t): Likewise. + (struct cbl_exception_t): Likewise. + (cbl_enabled_exception_t: Likewise.: Likewise.dump): Likewise. + (__gg__match_exception): Likewise. + (__gg__float128_from_location): Likewise. + (__gg__integer_from_float128): Likewise. + (__gg__set_exception_file): Likewise. + (__gg__func_exception_file): Likewise. + (__gg__set_exception_code): Likewise. + (__gg__is_float_infinite): Likewise. + (__gg__float32_from_128): Likewise. + (__gg__float32_from_64): Likewise. + (__gg__float64_from_128): Likewise. + (__gg__copy_as_big_endian): Likewise. + (__gg__get_figconst_data): Likewise. + (find_in_dirs): Likewise. + (__gg__function_handle_from_cobpath): Likewise. + (__gg__just_mangle_name): Likewise. + (__gg__function_handle_from_literal): Likewise. + (__gg__function_handle_from_name): Likewise. + (__gg__mirror_range): Likewise. + (__gg__deallocate): Likewise. + (__gg__allocate): Likewise. + (__gg__module_name): Likewise. + (__gg__set_env_name): Likewise. + (__gg__set_env_value): Likewise. + * libgcobol.h (__gg__mabort): Likewise. + (massert): Likewise. + (PTRCAST): Likewise. + (__gg__float128_from_location): Likewise. + (__gg__set_exception_file): Likewise. + (__gg__binary_value_from_qualified_field): Likewise. + (__gg__float128_from_qualified_field): Likewise. + * valconv.cc (__gg__realloc_if_necessary): Likewise. + (__gg__alphabet_create): Likewise. + (__gg__string_to_numeric_edited): Likewise. + (__gg__string_to_alpha_edited): Likewise. + * valconv.h: Likewise. + 2025-06-01 Robert Dubner <rdubner@symas.com> PR cobol/119524 diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc index 2cdcfc0..eb82609 100644 --- a/libgcobol/charmaps.cc +++ b/libgcobol/charmaps.cc @@ -435,7 +435,7 @@ __gg__raw_to_ascii(char **dest, size_t *dest_size, const char *in, size_t length size_t code_point; // Pull the next code_point from the UTF-8 stream - long unicode_point = extract_next_code_point((const unsigned char *)in, + long unicode_point = extract_next_code_point(reinterpret_cast<const unsigned char *>(in), length, position ); @@ -497,7 +497,7 @@ __gg__raw_to_ebcdic(char **dest, size_t *dest_size, const char *in, size_t lengt } // Pull the next code_point from the UTF-8 stream - long unicode_point = extract_next_code_point( (const unsigned char *)in, + long unicode_point = extract_next_code_point( reinterpret_cast<const unsigned char *>(in), length, position ); // Check for that unicode code point in the subset of characters we @@ -722,7 +722,8 @@ char *__gg__ebcdic_to_console(char **dest, const size_t length) { static size_t ebcdic_size = MINIMUM_ALLOCATION_SIZE; - static char *ebcdic = (char *)malloc(ebcdic_size); + static char *ebcdic = static_cast<char *>(malloc(ebcdic_size)); + if(!ebcdic)abort(); __gg__realloc_if_necessary(&ebcdic, &ebcdic_size, length); memcpy(ebcdic, str, length); @@ -757,7 +758,7 @@ void __gg__console_to_ascii(char * const str, size_t length) size_t code_point; // Pull the next code_point from the UTF-8 stream long unicode_point - = extract_next_code_point( (const unsigned char *)str, + = extract_next_code_point( reinterpret_cast<const unsigned char *>(str), length, position ); if( unicode_point == -1 ) @@ -797,7 +798,7 @@ __gg__console_to_ebcdic(char * const str, size_t length) size_t code_point; // Pull the next code_point from the UTF-8 stream long unicode_point - = extract_next_code_point( (const unsigned char *)str, + = extract_next_code_point( reinterpret_cast<const unsigned char *>(str), length, position ); if( unicode_point == -1 ) diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h index 2aecc8f..764d9f8 100644 --- a/libgcobol/common-defs.h +++ b/libgcobol/common-defs.h @@ -464,16 +464,20 @@ struct cbl_declarative_t { uint32_t nfile, files[files_max]; cbl_file_mode_t mode; + // cppcheck-suppress noExplicitConstructor cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e ) - : section(0), global(false) + : section(0) + , global(false) , type(ec_none_e) , nfile(0) , mode(mode) { std::fill(files, files + COUNT_OF(files), 0); } + // cppcheck-suppress noExplicitConstructor cbl_declarative_t( ec_type_t type ) - : section(0), global(false) + : section(0) + , global(false) , type(type) , nfile(0) , mode(file_mode_none_e) @@ -533,9 +537,9 @@ struct cbl_declarative_t { return section < that.section; } - // TRUE if there are no files to match, or the provided file is in the list. - bool match_file( size_t file ) const { - static const auto pend = files + nfile; + // TRUE if there are no files to match, or the provided file is in the list. + bool match_file( size_t file ) const { + static const auto pend = files + nfile; // cppcheck-suppress constVariablePointer return nfile == 0 || pend != std::find(files, files + nfile, file); } diff --git a/libgcobol/config.h.in b/libgcobol/config.h.in index ee3dd6b..1b511d0 100644 --- a/libgcobol/config.h.in +++ b/libgcobol/config.h.in @@ -3,6 +3,9 @@ /* Define to 1 if the target assembler supports thread-local storage. */ #undef HAVE_CC_TLS +/* Define to 1 if you have the `clock_gettime' function. */ +#undef HAVE_CLOCK_GETTIME + /* Define to 1 if you have the <complex.h> header file. */ #undef HAVE_COMPLEX_H diff --git a/libgcobol/configure b/libgcobol/configure index 5f319ee..7271517 100755 --- a/libgcobol/configure +++ b/libgcobol/configure @@ -17275,6 +17275,59 @@ if test "$ac_res" != no; then : fi +# Copied from gcc/configure.ac. 2025-06-05 R.J.Dubner +# At least for glibc, clock_gettime is in librt. But don't pull that +# in if it still doesn't give us the function we want. +ac_cv_func_clock_gettime=no +if test $ac_cv_func_clock_gettime = no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for clock_gettime in -lrt" >&5 +$as_echo_n "checking for clock_gettime in -lrt... " >&6; } +if ${ac_cv_lib_rt_clock_gettime+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lrt $LIBS" +if test x$gcc_no_link = xyes; then + as_fn_error $? "Link tests are not allowed after GCC_NO_EXECUTABLES." "$LINENO" 5 +fi +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char clock_gettime (); +int +main () +{ +return clock_gettime (); + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_link "$LINENO"; then : + ac_cv_lib_rt_clock_gettime=yes +else + ac_cv_lib_rt_clock_gettime=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rt_clock_gettime" >&5 +$as_echo "$ac_cv_lib_rt_clock_gettime" >&6; } +if test "x$ac_cv_lib_rt_clock_gettime" = xyes; then : + LIBS="-lrt $LIBS" + +$as_echo "#define HAVE_CLOCK_GETTIME 1" >>confdefs.h + +fi + +fi + have_iec_60559_libc_support=no if test "x$ac_cv_func_strtof128$ac_cv_func_strfromf128" = xyesyes \ && test "x$libgcobol_have_sinf128$libgcobol_have_cacosf128" = xyesyes; then diff --git a/libgcobol/configure.ac b/libgcobol/configure.ac index 1332696..acfca7e 100644 --- a/libgcobol/configure.ac +++ b/libgcobol/configure.ac @@ -232,6 +232,17 @@ AC_SEARCH_LIBS([sinf128], [c m], libgcobol_have_sinf128=yes) libgcobol_have_cacosf128=no AC_SEARCH_LIBS([cacosf128], [c m], libgcobol_have_cacosf128=yes) +# Copied from gcc/configure.ac. 2025-06-05 R.J.Dubner +# At least for glibc, clock_gettime is in librt. But don't pull that +# in if it still doesn't give us the function we want. +ac_cv_func_clock_gettime=no +if test $ac_cv_func_clock_gettime = no; then + AC_CHECK_LIB(rt, clock_gettime, + [LIBS="-lrt $LIBS" + AC_DEFINE(HAVE_CLOCK_GETTIME, 1, + [Define to 1 if you have the `clock_gettime' function.])]) +fi + have_iec_60559_libc_support=no if test "x$ac_cv_func_strtof128$ac_cv_func_strfromf128" = xyesyes \ && test "x$libgcobol_have_sinf128$libgcobol_have_cacosf128" = xyesyes; then diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc index 806f4a9..9124288 100644 --- a/libgcobol/gfileio.cc +++ b/libgcobol/gfileio.cc @@ -105,6 +105,11 @@ */ +/* cppcheck has its opinions about ++iterator being superior to iterator++. + however, can't abide by the prefix notation; it just looks dumb to me. + And I have to believe that in the year of our Lord 2025 that the + optimizing algorithms in modern compilers have sorted this out by now. */ + extern "C" void __gg__handle_error(const char *function, const char *msg) @@ -191,11 +196,12 @@ handle_errno(cblc_file_t *file, const char *function, const char *msg) static char * -get_filename( cblc_file_t *file, +get_filename( const cblc_file_t *file, int is_quoted) { static size_t fname_size = MINIMUM_ALLOCATION_SIZE; - static char *fname = (char *)malloc(MINIMUM_ALLOCATION_SIZE); + static char *fname = static_cast<char *>(malloc(MINIMUM_ALLOCATION_SIZE)); + massert(fname); fname = internal_to_console(&fname, &fname_size, file->filename, @@ -205,14 +211,15 @@ get_filename( cblc_file_t *file, { // We have been given something that might be the name of an // environment variable that contains the filename: - char *p_from_environment = getenv(fname); + const char *p_from_environment = getenv(fname); if( p_from_environment ) { if( strlen(p_from_environment)+1 > fname_size ) { fname_size = strlen(p_from_environment)+1; free(fname); - fname = (char *)malloc(fname_size); + fname = static_cast<char *>(malloc(fname_size)); + massert(fname); } strcpy(fname, p_from_environment); } @@ -272,7 +279,7 @@ __gg__set_user_status(cblc_field_t *ustatus, cblc_file_t *file) } static long -max_value(cblc_field_t *key) +max_value(const cblc_field_t *key) { long retval; if( key->digits ) @@ -537,7 +544,8 @@ relative_file_delete_varying(cblc_file_t *file, bool is_random) size_t payload_length; - unsigned char *stash = (unsigned char *)malloc(file->default_record->capacity); + unsigned char *stash = static_cast<unsigned char *>(malloc(file->default_record->capacity)); + massert(stash); memcpy(stash, file->default_record->data, file->default_record->capacity); long starting_pos = ftell(file->file_pointer); @@ -654,7 +662,8 @@ relative_file_delete(cblc_file_t *file, bool is_random) char record_marker; - unsigned char *stash = (unsigned char *)malloc(file->default_record->capacity); + unsigned char *stash = static_cast<unsigned char *>(malloc(file->default_record->capacity)); + massert(stash); memcpy(stash, file->default_record->data, file->default_record->capacity); long starting_pos = ftell(file->file_pointer); @@ -829,7 +838,7 @@ read_an_indexed_record( cblc_file_t *file, goto done; } - record_length = ach[0]<<8; + record_length = static_cast<long>(ach[0])<<8; record_length += ach[1]; if(ach[2] != 0) { @@ -906,7 +915,7 @@ position_state_preserve(cblc_file_t *file, position_state_t &state) } static void -position_state_restore(cblc_file_t *file, position_state_t &state) +position_state_restore(cblc_file_t *file, const position_state_t &state) { file->recent_key = state.recent_key; fseek(file->file_pointer, state.starting_position, SEEK_SET); @@ -973,7 +982,8 @@ indexed_file_delete(cblc_file_t *file, bool is_random) // and the record area itself are unchanged by the delete operation. // So, we save the current record area: - stash = (unsigned char *)malloc(file->record_area_max); + stash = static_cast<unsigned char *>(malloc(file->record_area_max)); + massert(stash); memcpy(stash, file->default_record->data, file->record_area_max); // And the position state of our file @@ -1051,8 +1061,6 @@ indexed_file_delete(cblc_file_t *file, bool is_random) // we find one, we check to see if the keys match. If the keys don't // match, then we have to remove the existing one from the index. - std::vector<unsigned char> the_key - = file_indexed_make_key(file, key_number); bool deleting = true; while(deleting) { @@ -1069,6 +1077,7 @@ indexed_file_delete(cblc_file_t *file, bool is_random) deleting = true; break; } + it++; } } @@ -1234,7 +1243,7 @@ indexed_file_start( cblc_file_t *file, file->io_status = FsErrno; } } - else if( result < 0 ) + else // if( result < 0 ) { // The index is less than the key. if( relop == lt_op @@ -1656,7 +1665,7 @@ sequential_file_rewrite( cblc_file_t *file, size_t length ) if( file->record_area_min != file->record_area_max ) { - unsigned char preamble[4] = + const unsigned char preamble[4] = { (unsigned char)(bytes_to_write>>8), (unsigned char)(bytes_to_write), @@ -1688,7 +1697,6 @@ done: fseek(file->file_pointer, starting_position, SEEK_SET); handle_ferror(file, __func__, "fseek() error"); file->prior_op = file_op_rewrite; - file->prior_op = file_op_rewrite; establish_status(file, starting_position); } @@ -2210,7 +2218,7 @@ __io__file_rewrite(cblc_file_t *file, size_t length, bool is_random) static void relative_file_write_varying(cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, bool is_random) { @@ -2359,7 +2367,7 @@ done: static void relative_file_write(cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, bool is_random) { @@ -2374,7 +2382,7 @@ relative_file_write(cblc_file_t *file, file->io_status = FsErrno; long necessary_file_size; - unsigned char achPostamble[] = {internal_cr, internal_newline}; + const unsigned char achPostamble[] = {internal_cr, internal_newline}; relative_file_parameters rfp; @@ -2493,7 +2501,7 @@ done: static void sequential_file_write(cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, int after, int lines) @@ -2609,7 +2617,7 @@ sequential_file_write(cblc_file_t *file, { // Because of the min/max mismatch, we require a preamble: // The first two bytes are the big-endian character count - unsigned char preamble[4] = + const unsigned char preamble[4] = { (unsigned char)(characters_to_write>>8), (unsigned char)(characters_to_write), @@ -2681,7 +2689,7 @@ done: static void indexed_file_write( cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, bool is_random) { @@ -2752,13 +2760,13 @@ indexed_file_write( cblc_file_t *file, // We are allowed to do the write, but only if there will be no key // violations as a result: - for(size_t key_number=1; - key_number<file->supplemental->indexes.size(); - key_number++) + for(size_t keynum=1; + keynum<file->supplemental->indexes.size(); + keynum++) { - if( file->supplemental->uniques[key_number] ) + if( file->supplemental->uniques[keynum] ) { - long record_position = file_indexed_first_position(file, key_number); + long record_position = file_indexed_first_position(file, keynum); if( record_position != -1 ) { // No can do, because we already have a unique key with that value @@ -2849,7 +2857,7 @@ done: static void __io__file_write( cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, int after, int lines, @@ -2983,7 +2991,7 @@ line_sequential_file_read( cblc_file_t *file) { break; } - if( ch == file->delimiter || ch == EOF ) + if( ch == EOF ) { hit_eof = true; clearerr(file->file_pointer); @@ -3647,6 +3655,7 @@ indexed_file_read( cblc_file_t *file, goto done; } + // cppcheck-suppress derefInvalidIteratorRedundantCheck fpos = file_index->current_iterator->second; if( file_index->current_iterator == file_index->key_to_position.end() ) @@ -3728,6 +3737,7 @@ indexed_file_read( cblc_file_t *file, // We are ready to proceed + // cppcheck-suppress derefInvalidIteratorRedundantCheck fpos = file_index->current_iterator->second; if( file_index->current_iterator == file_index->key_to_position.end() ) { @@ -3922,7 +3932,6 @@ file_indexed_open(cblc_file_t *file) { if( file->key_numbers[index] != current_key_number ) { - file_index_t file_index; file->supplemental->indexes.push_back(file_index); current_key_number = file->key_numbers[index]; file->supplemental->uniques.push_back(file->uniques[index]); @@ -3952,7 +3961,8 @@ file_indexed_open(cblc_file_t *file) // We need to open the file for reading, and build the // maps for each index: static size_t fname_size = MINIMUM_ALLOCATION_SIZE; - static char *fname = (char *)malloc(fname_size); + static char *fname = static_cast<char *>(malloc(fname_size)); + massert(fname); internal_to_console(&fname, &fname_size, @@ -3969,7 +3979,8 @@ file_indexed_open(cblc_file_t *file) } // Stash the existing record area: - stash = (unsigned char *)malloc(file->record_area_max); + stash = static_cast<unsigned char *>(malloc(file->record_area_max)); + massert(stash); memcpy( stash, file->default_record->data, file->record_area_max); @@ -4111,7 +4122,8 @@ __gg__file_reopen(cblc_file_t *file, int mode_char) } static size_t fname_size = MINIMUM_ALLOCATION_SIZE; - static char *fname = (char *)malloc(fname_size); + static char *fname = static_cast<char *>(malloc(fname_size)); + massert(fname) internal_to_console(&fname, &fname_size, file->filename, @@ -4465,7 +4477,7 @@ public: typedef void (read_t)( cblc_file_t *file, int where ); typedef void (write_t)( cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, int after, int lines, diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index e51cf9f..8a9880b 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -88,7 +88,8 @@ conditional_stash( cblc_field_t *destination, // This is slightly more complex, because in the event of a // SIZE ERROR. we need to leave the original value untouched - unsigned char *stash = (unsigned char *)malloc(destination_s); + unsigned char *stash = static_cast<unsigned char *>(malloc(destination_s)); + massert(stash); memcpy(stash, destination->data+destination_o, destination_s); __gg__int128_to_qualified_field(destination, @@ -132,7 +133,9 @@ conditional_stash( cblc_field_t *destination, { // This is slightly more complex, because in the event of a // SIZE ERROR. we need to leave the original value untouched - unsigned char *stash = (unsigned char *)malloc(destination_s); + assert(destination_s); + unsigned char *stash = static_cast<unsigned char *>(malloc(destination_s)); + massert(stash); memcpy(stash, destination->data+destination_o, destination_s); __gg__float128_to_qualified_field(destination, destination_o, @@ -256,20 +259,20 @@ __gg__pow( cbl_arith_format_t, size_t, size_t, size_t, - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; GCOB_FP128 avalue = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); GCOB_FP128 bvalue = __gg__float128_from_qualified_field(B[0], B_o[0], B_s[0]); @@ -368,8 +371,8 @@ multiply_int256_by_int64(int256 &product, const uint64_t multiplier) for(int i=0; i<4; i++) { uint128 temp = (uint128)product.i64[i] * multiplier; - product.i64[i] = *(uint64_t *)(&temp); - overflows[i+1] = *(uint64_t *)((uint8_t *)(&temp) + 8); + product.i64[i] = *PTRCAST(uint64_t, &temp); + overflows[i+1] = *PTRCAST(uint64_t, PTRCAST(uint8_t, &temp) + 8); } for(int i=1; i<4; i++) @@ -386,7 +389,7 @@ multiply_int256_by_int64(int256 &product, const uint64_t multiplier) } static int -add_int256_to_int256(int256 &sum, const int256 addend) +add_int256_to_int256(int256 &sum, const int256 &addend) { uint128 overflows[3] = {}; for(int i=0; i<2; i++) @@ -451,10 +454,11 @@ divide_int256_by_int64(int256 &val, uint64_t divisor) for( int i=3; i>=0; i-- ) { // Left shift temp 64 bits: - *(uint64_t *)(((uint8_t *)&temp)+8) = *(uint64_t *)(((uint8_t *)&temp)+0); + *PTRCAST(uint64_t, ((PTRCAST(uint8_t, &temp))+8)) + = *PTRCAST(uint64_t, ((PTRCAST(uint8_t, &temp))+0)); // Put the high digit of val into the bottom of temp - *(uint64_t *)(((uint8_t *)&temp)+0) = val.i64[i]; + *PTRCAST(uint64_t, ((PTRCAST(uint8_t, &temp))+0)) = val.i64[i]; // Divide that combinary by divisor to get the new digits val.i64[i] = temp / divisor; @@ -469,7 +473,8 @@ squeeze_int256(int256 &val, int &rdigits) { int overflow = 0; // It has been decreed that at this juncture the result must fit into - // MAX_FIXED_POINT_DIGITS. If the result does not, we have an OVERFLOW error. + // MAX_FIXED_POINT_DIGITS. If the result does not, we have an OVERFLOW + // error. int is_negative = val.data[31] & 0x80; if( is_negative ) @@ -477,9 +482,9 @@ squeeze_int256(int256 &val, int &rdigits) negate_int256(val); } - // As long as there are some decimal places left, we hold our nose and right- - // shift a too-large value rightward by decimal digits. In other words, we - // truncate the fractional part to make room for the integer part: + // As long as there are some decimal places left, we hold our nose and + // right-shift a too-large value rightward by decimal digits. In other + // words, we truncate the fractional part to make room for the integer part: while(rdigits > 0 && val.i128[1] ) { divide_int256_by_int64(val, 10UL); @@ -504,7 +509,7 @@ squeeze_int256(int256 &val, int &rdigits) // These sixteen bytes comprise the binary value of 10^38 static const uint8_t C1038[] = {0x00, 0x00, 0x00, 0x00, 0x40, 0x22, 0x8a, 0x09, 0x7a, 0xc4, 0x86, 0x5a, 0xa8, 0x4c, 0x3b, 0x4b}; - static const uint128 biggest = *(uint128 *)C1038; + static const uint128 biggest = *reinterpret_cast<const uint128 *>(C1038); // If we still have some rdigits to throw away, we can keep shrinking // the value: @@ -540,7 +545,7 @@ squeeze_int256(int256 &val, int &rdigits) static void get_int256_from_qualified_field(int256 &var, int &rdigits, - cblc_field_t *field, + const cblc_field_t *field, size_t field_o, size_t field_s) { @@ -571,7 +576,7 @@ __gg__add_fixed_phase1( cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *, + const cbl_round_t *, int , int *compute_error ) @@ -580,9 +585,9 @@ __gg__add_fixed_phase1( cbl_arith_format_t , // The result goes into the temporary phase1_result. - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; // Let us prime the pump with the first value of A[] get_int256_from_qualified_field(phase1_result, phase1_rdigits, A[0], A_o[0], A_s[0]); @@ -600,7 +605,6 @@ __gg__add_fixed_phase1( cbl_arith_format_t , if( phase1_rdigits > temp_rdigits ) { scale_int256_by_digits(temp, phase1_rdigits - temp_rdigits); - temp_rdigits = phase1_rdigits; } else if( phase1_rdigits < temp_rdigits ) { @@ -628,14 +632,14 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; // This is the assignment phase of an ADD Format 1 @@ -680,7 +684,6 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , if( rdigits_a > rdigits_b ) { scale_int256_by_digits(value_b, rdigits_a - rdigits_b); - rdigits_b = rdigits_a; } else if( rdigits_a < rdigits_b ) { @@ -713,16 +716,16 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { // This is the assignment phase of an ADD Format 2 - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; // We take phase1_result and put it into C @@ -771,7 +774,7 @@ __gg__add_float_phase1( cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *, + const cbl_round_t *, int , int *compute_error ) @@ -780,9 +783,9 @@ __gg__add_float_phase1( cbl_arith_format_t , // The result goes into the temporary phase1_result_ffloat. - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; // Let us prime the pump with the first value of A[] phase1_result_float = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); @@ -804,14 +807,14 @@ __gg__addf1_float_phase2( cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); // This is the assignment phase of an ADD Format 2 @@ -831,14 +834,14 @@ __gg__float_phase2_assign_to_c( cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); // This is the assignment phase of an ADD Format 2 @@ -856,7 +859,7 @@ __gg__addf3(cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) @@ -864,13 +867,13 @@ __gg__addf3(cbl_arith_format_t , // This is an ADD Format 3. Each A[i] gets accumulated into each C[i]. When // both are fixed, we do fixed arithmetic. When either is a FldFloat, we // do floating-point arithmetic. - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); @@ -906,7 +909,6 @@ __gg__addf3(cbl_arith_format_t , if( rdigits_a > rdigits_b ) { scale_int256_by_digits(value_b, rdigits_a - rdigits_b); - rdigits_b = rdigits_a; } else if( rdigits_a < rdigits_b ) { @@ -940,14 +942,14 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; // This is the assignment phase of an ADD Format 1 @@ -997,7 +999,6 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , else if( rdigits_a < rdigits_b ) { scale_int256_by_digits(value_a, rdigits_b - rdigits_a); - rdigits_a = rdigits_b; } // The two numbers have the same number of rdigits. It's now safe to add @@ -1025,16 +1026,16 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { // This is the calculation phase of a fixed-point SUBTRACT Format 2 - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; // Add up all the A values __gg__add_fixed_phase1( not_expected_e , @@ -1065,7 +1066,6 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , else if( rdigits_a < rdigits_b ) { scale_int256_by_digits(value_a, rdigits_b - rdigits_a); - rdigits_a = rdigits_b; } // The two numbers have the same number of rdigits. It's now safe to add @@ -1081,21 +1081,20 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , phase1_rdigits = rdigits_b; } - extern "C" void __gg__subtractf1_float_phase2(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); // This is the assignment phase of an ADD Format 2 @@ -1109,23 +1108,22 @@ __gg__subtractf1_float_phase2(cbl_arith_format_t , *rounded++); } - extern "C" void __gg__subtractf2_float_phase1(cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { // This is the calculation phase of a fixed-point SUBTRACT Format 2 - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; // Add up all the A values __gg__add_float_phase1( not_expected_e , @@ -1151,7 +1149,7 @@ __gg__subtractf3( cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) @@ -1159,12 +1157,12 @@ __gg__subtractf3( cbl_arith_format_t , // This is an ADD Format 3. Each A[i] gets accumulated into each C[i]. Each // SUBTRACTION is treated separately. - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); @@ -1205,7 +1203,6 @@ __gg__subtractf3( cbl_arith_format_t , else if( rdigits_a < rdigits_b ) { scale_int256_by_digits(value_a, rdigits_b - rdigits_a); - rdigits_a = rdigits_b; } // The two numbers have the same number of rdigits. It's now safe to add @@ -1240,16 +1237,16 @@ __gg__multiplyf1_phase1(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *, + const cbl_round_t *, int , int *) { // We are getting just the one value, which we are converting to the necessary // intermediate form - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; if( A[0]->type == FldFloat ) { @@ -1274,7 +1271,8 @@ void multiply_int128_by_int128(int256 &ABCD, __int128 ab_value, __int128 cd_value) { - int is_negative = ( ((uint8_t *)(&ab_value))[15]^((uint8_t *)(&cd_value))[15]) & 0x80; + int is_negative = ( (PTRCAST(uint8_t, (&ab_value)))[15] + ^(PTRCAST(uint8_t, (&cd_value)))[15]) & 0x80; if( ab_value < 0 ) { ab_value = -ab_value; @@ -1290,10 +1288,10 @@ void multiply_int128_by_int128(int256 &ABCD, uint128 BD; // Let's extract the digits. - uint64_t a = *(uint64_t *)((unsigned char *)(&ab_value)+8); - uint64_t b = *(uint64_t *)((unsigned char *)(&ab_value)+0); - uint64_t c = *(uint64_t *)((unsigned char *)(&cd_value)+8); - uint64_t d = *(uint64_t *)((unsigned char *)(&cd_value)+0); + uint64_t a = *PTRCAST(uint64_t, (PTRCAST(unsigned char, (&ab_value))+8)); + uint64_t b = *PTRCAST(uint64_t, (PTRCAST(unsigned char, (&ab_value))+0)); + uint64_t c = *PTRCAST(uint64_t, (PTRCAST(unsigned char, (&cd_value))+8)); + uint64_t d = *PTRCAST(uint64_t, (PTRCAST(unsigned char, (&cd_value))+0)); // multiply (a0 + b) * (c0 + d) @@ -1334,14 +1332,14 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; @@ -1415,14 +1413,13 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , if( error_this_time && on_size_error) { *compute_error |= error_this_time; - rounded++; } else { *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], on_size_error, a_value, - *rounded++); + *rounded); } done: return; @@ -1434,20 +1431,20 @@ __gg__multiplyf2( cbl_arith_format_t , size_t , size_t , size_t nC, - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); @@ -1517,7 +1514,7 @@ shift_in_place128(uint8_t *buf, int size, int bits) uint128 temp; uint128 overflow = 0; - uint128 *as128 = (uint128 *)buf; + uint128 *as128 = PTRCAST(uint128, buf); for( size_t i=0; i<places; i++ ) { @@ -1598,7 +1595,7 @@ divide_int128_by_int128(int256 "ient, } // We are going to be referencing the 64-bit pices of the 128-bit divisor: - uint64_t *divisor64 = (uint64_t *)&divisor; + uint64_t *divisor64 = PTRCAST(uint64_t, &divisor); quotient.i128[1] = 0; quotient.i128[0] = dividend; @@ -1667,12 +1664,11 @@ divide_int128_by_int128(int256 "ient, int bits_to_shift = 0; int i=15; - while( ((uint8_t *)(&divisor))[i] == 0 ) + while( (PTRCAST(uint8_t, &divisor))[i] == 0 ) { i -= 1; bits_to_shift += 8; - } - uint8_t tail = ((uint8_t *)(&divisor))[i]; + } uint8_t tail = ( PTRCAST(uint8_t, &divisor) )[i]; while( !(tail & 0x80) ) { bits_to_shift += 1; @@ -1681,9 +1677,8 @@ divide_int128_by_int128(int256 "ient, // Shift both the numerator and the divisor that number of bits - shift_in_place128((uint8_t *)&numerator, sizeof(numerator), bits_to_shift); - shift_in_place128((uint8_t *)&divisor, sizeof(divisor), bits_to_shift); - + shift_in_place128( PTRCAST(uint8_t, &numerator), sizeof(numerator), bits_to_shift); + shift_in_place128( PTRCAST(uint8_t, &divisor), sizeof(divisor), bits_to_shift); // We are now ready to do the guess-multiply-subtract loop. We know that // the result will have two places, so we know we are going to go through @@ -1700,7 +1695,7 @@ divide_int128_by_int128(int256 "ient, // We develop our guess for a quotient by dividing the top two places of // the numerator area by C uint128 temp; - uint64_t *temp64 = (uint64_t *)&temp; + uint64_t *temp64 = PTRCAST(uint64_t, &temp); temp64[1] = numerator.i64[q_place+2]; temp64[0] = numerator.i64[q_place+1]; @@ -1714,10 +1709,10 @@ divide_int128_by_int128(int256 "ient, subber[2] = 0; // Start with the bottom 128 bits of the "subber" - *(uint128 *)subber = (uint128) divisor64[0] * quotient.i64[q_place]; + *PTRCAST(uint128, subber) = (uint128) divisor64[0] * quotient.i64[q_place]; // Get the next 128 bits of subber - temp = (uint128) divisor64[1] * quotient.i64[q_place]; + temp = (uint128) divisor64[1] * quotient.i64[q_place]; // Add the top of the first product to the bottom of the second: subber[1] += temp64[0]; @@ -1738,20 +1733,20 @@ divide_int128_by_int128(int256 "ient, // the numerator: uint64_t borrow = 0; - for(size_t i=0; i<3; i++) + for(size_t j=0; j<3; j++) { - if( numerator.i64[q_place + i] == 0 && borrow ) + if( numerator.i64[q_place + j] == 0 && borrow ) { // We are subtracting from zero and we have a borrow. Leave the // borrow on and just do the subtraction: - numerator.i64[q_place + i] -= subber[i]; + numerator.i64[q_place + j] -= subber[j]; } else { - uint64_t stash = numerator.i64[q_place + i]; - numerator.i64[q_place + i] -= borrow; - numerator.i64[q_place + i] -= subber[i]; - if( numerator.i64[q_place + i] > stash ) + uint64_t stash = numerator.i64[q_place + j]; + numerator.i64[q_place + j] -= borrow; + numerator.i64[q_place + j] -= subber[j]; + if( numerator.i64[q_place + j] > stash ) { // After subtracting, the value got bigger, which means we have // to borrow from the next value to the left @@ -1775,21 +1770,21 @@ divide_int128_by_int128(int256 "ient, { // We need to add subber back into the numerator area uint64_t carry = 0; - for(size_t i=0; i<3; i++) + for(size_t ii=0; ii<3; ii++) { - if( numerator.i64[q_place + i] == 0xFFFFFFFFFFFFFFFFUL && carry ) + if( numerator.i64[q_place + ii] == 0xFFFFFFFFFFFFFFFFUL && carry ) { // We are at the top and have a carry. Just leave the carry on // and do the addition: - numerator.i64[q_place + i] += subber[i]; + numerator.i64[q_place + ii] += subber[ii]; } else { // We are not at the top. - uint64_t stash = numerator.i64[q_place + i]; - numerator.i64[q_place + i] += carry; - numerator.i64[q_place + i] += subber[i]; - if( numerator.i64[q_place + i] < stash ) + uint64_t stash = numerator.i64[q_place + ii]; + numerator.i64[q_place + ii] += carry; + numerator.i64[q_place + ii] += subber[ii]; + if( numerator.i64[q_place + ii] < stash ) { // The addition caused the result to get smaller, meaning that // we wrapped around: @@ -1817,14 +1812,14 @@ __gg__dividef1_phase2(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; @@ -1904,14 +1899,13 @@ __gg__dividef1_phase2(cbl_arith_format_t , if( error_this_time && on_size_error) { - rounded++; } else { *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], on_size_error, b_value, - *rounded++); + *rounded); } done: return; @@ -1923,20 +1917,20 @@ __gg__dividef23(cbl_arith_format_t , size_t , size_t , size_t nC, - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; @@ -2009,15 +2003,15 @@ __gg__dividef45(cbl_arith_format_t , int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; // Numerator - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; // Denominator - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; // Has remainder, then quotient - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; // Numerator + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **B = __gg__treeplet_2f; // Denominator + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; + cblc_field_t **C = __gg__treeplet_3f; // Has remainder, then quotient + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc index 1af4a53..2d8d79c 100644 --- a/libgcobol/intrinsic.cc +++ b/libgcobol/intrinsic.cc @@ -167,7 +167,7 @@ JD_to_DOW(double JD) static char * -timespec_to_string(char *retval, struct timespec &tp) +timespec_to_string(char *retval, struct cbl_timespec &tp) { /* Returns a 21-character string: @@ -248,9 +248,12 @@ struct input_state nsubscript = N; if(N) { - subscript_alls = (bool *) malloc(nsubscript); - subscripts = (size_t *)malloc(nsubscript); - subscript_limits = (size_t *)malloc(nsubscript); + subscript_alls = static_cast<bool *>(malloc(nsubscript)); + subscripts = static_cast<size_t *>(malloc(nsubscript)); + subscript_limits = static_cast<size_t *>(malloc(nsubscript)); + massert(subscript_alls); + massert(subscripts); + massert(subscript_limits); } done = false; } @@ -378,7 +381,7 @@ year_to_yyyy(int arg1, int arg2, int arg3) static double -get_value_as_double_from_qualified_field( cblc_field_t *input, +get_value_as_double_from_qualified_field( const cblc_field_t *input, size_t input_o, size_t input_s) { @@ -411,9 +414,9 @@ get_value_as_double_from_qualified_field( cblc_field_t *input, static GCOB_FP128 kahan_summation(size_t ncount, cblc_field_t **source, - size_t *source_o, - size_t *source_s, - int *flags, + const size_t *source_o, + const size_t *source_s, + const int *flags, size_t *k_count) { // We use compensated addition. Look up Kahan summation. @@ -458,9 +461,9 @@ static GCOB_FP128 variance( size_t ncount, cblc_field_t **source, - size_t *source_o, - size_t *source_s, - int *flags) + const size_t *source_o, + const size_t *source_s, + const int *flags) { // In order to avoid catastrophic cancellation, we are going to use an // algorithm that is a bit wasteful of time, but is described as particularly @@ -547,14 +550,14 @@ get_all_time( char *stime, // days of January show up in the final week of the prior year. sprintf(stime, - "%4.4u%2.2u%2.2uT" // YYYYMMSS - "%2.2u%2.2u%2.2u" // hhmmss - ".%9.9u" // .sssssssss - "%c%2.2u%2.2u" // +hhmm - "W%2.2u" // Www - "%1u" // DOW [1-7], 1 for Monday - "%3.3u" // DDD day of year, 001 - 365,366 - "%4.4u", // ZZZZ Year for YYYY-Www-D + "%4.4d%2.2d%2.2dT" // YYYYMMSS + "%2.2d%2.2d%2.2d" // hhmmss + ".%9.9d" // .sssssssss + "%c%2.2d%2.2d" // +hhmm + "W%2.2d" // Www + "%1d" // DOW [1-7], 1 for Monday + "%3.3d" // DDD day of year, 001 - 365,366 + "%4.4d", // ZZZZ Year for YYYY-Www-D ctm.YYYY, ctm.MM, ctm.DD, @@ -687,7 +690,7 @@ populate_ctm_from_JD(struct cobol_tm &ctm, double JD ) static void populate_ctm_from_date( struct cobol_tm &ctm, - cblc_field_t *pdate, + const cblc_field_t *pdate, size_t pdate_offset, size_t pdate_size) { @@ -721,10 +724,10 @@ populate_ctm_from_double_time(struct cobol_tm &ctm, double time) static void populate_ctm_from_time( struct cobol_tm &ctm, - cblc_field_t *ptime, + const cblc_field_t *ptime, size_t ptime_o, size_t ptime_s, - cblc_field_t *poffset, + const cblc_field_t *poffset, size_t poffset_o, size_t poffset_s) { @@ -791,8 +794,10 @@ convert_to_zulu(cobol_tm &ctm) static void -ftime_replace(char *dest, char const * const dest_end, - char const *source, char const * const source_end, +ftime_replace(char *dest, + char const * const dest_end, + char const * source, + char const * const source_end, char const * const ftime) { // This routine is highly dependent on the source format being correct. @@ -956,7 +961,7 @@ ftime_replace(char *dest, char const * const dest_end, extern "C" void __gg__abs(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -978,7 +983,7 @@ __gg__abs(cblc_field_t *dest, extern "C" void __gg__acos( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1005,10 +1010,10 @@ __gg__acos( cblc_field_t *dest, extern "C" void __gg__annuity(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -1050,7 +1055,7 @@ __gg__annuity(cblc_field_t *dest, extern "C" void __gg__asin( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1080,7 +1085,7 @@ __gg__asin( cblc_field_t *dest, extern "C" void __gg__atan( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1102,7 +1107,7 @@ __gg__atan( cblc_field_t *dest, extern "C" void __gg__byte_length(cblc_field_t *dest, - cblc_field_t */*source*/, + const cblc_field_t */*source*/, size_t /*source_offset*/, size_t source_size) { @@ -1118,7 +1123,7 @@ __gg__byte_length(cblc_field_t *dest, extern "C" void __gg__char( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1143,10 +1148,10 @@ __gg__char( cblc_field_t *dest, extern "C" void __gg__combined_datetime(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -1192,7 +1197,7 @@ __gg__concat( cblc_field_t *dest, extern "C" void __gg__cos(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1213,7 +1218,7 @@ void __gg__current_date(cblc_field_t *dest) { // FUNCTION CURRENT-DATE - struct timespec tp = {}; + struct cbl_timespec tp = {}; __gg__clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec char retval[DATE_STRING_BUFFER_SIZE]; @@ -1227,7 +1232,7 @@ void __gg__seconds_past_midnight(cblc_field_t *dest) { // SECONDS-PAST-MIDNIGHT - struct timespec tp = {}; + struct cbl_timespec tp = {}; struct tm tm; __int128 retval=0; @@ -1251,7 +1256,7 @@ __gg__seconds_past_midnight(cblc_field_t *dest) extern "C" void __gg__date_of_integer(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1277,13 +1282,13 @@ __gg__date_of_integer(cblc_field_t *dest, extern "C" void __gg__date_to_yyyymmdd( cblc_field_t *dest, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_o, size_t par1_s, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_o, size_t par2_s, - cblc_field_t *par3, + const cblc_field_t *par3, size_t par3_o, size_t par3_s) { @@ -1308,7 +1313,7 @@ __gg__date_to_yyyymmdd( cblc_field_t *dest, extern "C" void __gg__day_of_integer( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1337,13 +1342,13 @@ __gg__day_of_integer( cblc_field_t *dest, extern "C" void __gg__day_to_yyyyddd( cblc_field_t *dest, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_o, size_t par1_s, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_o, size_t par2_s, - cblc_field_t *par3, + const cblc_field_t *par3, size_t par3_o, size_t par3_s) { @@ -1382,7 +1387,7 @@ __gg__e(cblc_field_t *dest) extern "C" void __gg__exp(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1401,7 +1406,7 @@ __gg__exp(cblc_field_t *dest, extern "C" void __gg__exp10(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1420,7 +1425,7 @@ __gg__exp10(cblc_field_t *dest, extern "C" void __gg__factorial(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1451,24 +1456,24 @@ __gg__factorial(cblc_field_t *dest, extern "C" void __gg__formatted_current_date( cblc_field_t *dest, // Destination string - cblc_field_t *input, // datetime format + const cblc_field_t *input, // datetime format size_t input_offset, size_t input_size) { // FUNCTION CURRENT-DATE // Establish the destination, and set it to spaces - char *d = (char *)dest->data; - char *dend = d + dest->capacity; + char *d = PTRCAST(char, dest->data); + const char *dend = d + dest->capacity; memset(d, internal_space, dest->capacity); // Establish the formatting string: - char *format = (char *)(input->data+input_offset); - char *format_end = format + input_size; + const char *format = PTRCAST(char, (input->data+input_offset)); + const char *format_end = format + input_size; bool is_zulu = false; - char *p = format; + const char *p = format; while( p < format_end ) { int ch = *p++; @@ -1479,7 +1484,7 @@ __gg__formatted_current_date( cblc_field_t *dest, // Destination string } } - struct timespec ts = {}; + struct cbl_timespec ts = {}; __gg__clock_gettime(CLOCK_REALTIME, &ts); struct tm tm = {}; @@ -1512,23 +1517,23 @@ __gg__formatted_current_date( cblc_field_t *dest, // Destination string extern "C" void __gg__formatted_date(cblc_field_t *dest, // Destination string - cblc_field_t *arg1, // datetime format + const cblc_field_t *arg1, // datetime format size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, // integer date + const cblc_field_t *arg2, // integer date size_t arg2_offset, size_t arg2_size) { // FUNCTION FORMATTED-DATE // Establish the destination, and set it to spaces - char *d = (char *)dest->data; - char *dend = d + dest->capacity; + char *d = PTRCAST(char, dest->data); + const char *dend = d + dest->capacity; memset(d, internal_space, dest->capacity); // Establish the formatting string: - char *format = (char *)(arg1->data+arg1_offset); - char *format_end = format + arg1_size; + char *format = PTRCAST(char, (arg1->data+arg1_offset)); + const char *format_end = format + arg1_size; struct cobol_tm ctm = {}; @@ -1550,16 +1555,16 @@ __gg__formatted_date(cblc_field_t *dest, // Destination string extern "C" void __gg__formatted_datetime( cblc_field_t *dest, // Destination string - cblc_field_t *par1, // datetime format + const cblc_field_t *par1, // datetime format size_t par1_o, size_t par1_s, - cblc_field_t *par2, // integer date + const cblc_field_t *par2, // integer date size_t par2_o, size_t par2_s, - cblc_field_t *par3, // numeric time + const cblc_field_t *par3, // numeric time size_t par3_o, size_t par3_s, - cblc_field_t *par4, // optional offset in seconds + const cblc_field_t *par4, // optional offset in seconds size_t par4_o, size_t par4_s ) @@ -1567,12 +1572,12 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string // FUNCTION FORMATTED-DATETIME // Establish the destination, and set it to spaces - char *d = (char *)dest->data; - char *dend = d + dest->capacity; + char *d = PTRCAST(char, (dest->data)); + const char *dend = d + dest->capacity; memset(d, internal_space, dest->capacity); // Establish the formatting string: - char *format = (char *)(par1->data+par1_o); + char *format = PTRCAST(char, (par1->data+par1_o)); char *format_end = format + par1_s; trim_trailing_spaces(format, format_end); bool is_zulu = is_zulu_format(format, format_end); @@ -1605,13 +1610,13 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string extern "C" void __gg__formatted_time( cblc_field_t *dest,// Destination string - cblc_field_t *par1, // datetime format + const cblc_field_t *par1, // datetime format size_t par1_o, size_t par1_s, - cblc_field_t *par2,// numeric time + const cblc_field_t *par2,// numeric time size_t par2_o, size_t par2_s, - cblc_field_t *par4, // optional offset in seconds + const cblc_field_t *par4, // optional offset in seconds size_t par4_o, size_t par4_s) @@ -1619,12 +1624,12 @@ __gg__formatted_time( cblc_field_t *dest,// Destination string // FUNCTION FORMATTED-TIME // Establish the destination, and set it to spaces - char *d = (char *)dest->data; - char *dend = d + dest->capacity; + char *d = PTRCAST(char, dest->data); + const char *dend = d + dest->capacity; memset(d, internal_space, dest->capacity); // Establish the formatting string: - char *format = (char *)(par1->data+par1_o); + char *format = PTRCAST(char, (par1->data+par1_o)); char *format_end = format + par1_s; trim_trailing_spaces(format, format_end); bool is_zulu = is_zulu_format(format, format_end); @@ -1659,7 +1664,7 @@ __gg__formatted_time( cblc_field_t *dest,// Destination string extern "C" void __gg__integer(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1677,7 +1682,7 @@ __gg__integer(cblc_field_t *dest, extern "C" void __gg__integer_of_date(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1732,7 +1737,7 @@ __gg__integer_of_date(cblc_field_t *dest, extern "C" void __gg__integer_of_day( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1759,7 +1764,7 @@ __gg__integer_of_day( cblc_field_t *dest, extern "C" void __gg__integer_part( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1782,7 +1787,7 @@ __gg__integer_part( cblc_field_t *dest, extern "C" void __gg__fraction_part(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1811,10 +1816,10 @@ __gg__fraction_part(cblc_field_t *dest, extern "C" void -__gg__log( cblc_field_t *dest, - cblc_field_t *source, - size_t source_offset, - size_t source_size) +__gg__log(cblc_field_t *dest, + const cblc_field_t *source, + size_t source_offset, + size_t source_size) { // FUNCTION LOG GCOB_FP128 value = __gg__float128_from_qualified_field(source, @@ -1836,10 +1841,10 @@ __gg__log( cblc_field_t *dest, extern "C" void -__gg__log10( cblc_field_t *dest, - cblc_field_t *source, - size_t source_offset, - size_t source_size) +__gg__log10(cblc_field_t *dest, + const cblc_field_t *source, + size_t source_offset, + size_t source_size) { // FUNCTION LOG10 GCOB_FP128 value = __gg__float128_from_qualified_field(source, @@ -1870,8 +1875,8 @@ __gg__max(cblc_field_t *dest, || __gg__treeplet_1f[0]->type == FldLiteralA) ) { cblc_field_t *best_field ; - unsigned char *best_location ; - size_t best_length ; + unsigned char *best_location = nullptr ; + size_t best_length = 0 ; int best_attr ; int best_flags ; @@ -1931,8 +1936,10 @@ __gg__max(cblc_field_t *dest, } } + __gg__adjust_dest_size(dest, best_length); dest->type = FldAlphanumeric; + assert(best_location); memcpy(dest->data, best_location, best_length); } else @@ -1977,7 +1984,7 @@ __gg__max(cblc_field_t *dest, extern "C" void __gg__lower_case( cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { @@ -1985,10 +1992,10 @@ __gg__lower_case( cblc_field_t *dest, size_t source_length = input_size; memset(dest->data, internal_space, dest_length); memcpy(dest->data, input->data+input_offset, std::min(dest_length, source_length)); - internal_to_ascii((char *)dest->data, dest_length); + internal_to_ascii( PTRCAST(char, dest->data), dest_length); std::transform(dest->data, dest->data + dest_length, dest->data, [](unsigned char c) { return std::tolower(c); }); - ascii_to_internal_str((char *)dest->data, dest_length); + ascii_to_internal_str( PTRCAST(char, dest->data), dest_length); } extern "C" @@ -2027,7 +2034,8 @@ __gg__median( cblc_field_t *dest, size_t list_size = 1; - GCOB_FP128 *the_list = (GCOB_FP128 *)malloc(list_size *sizeof(GCOB_FP128)); + GCOB_FP128 *the_list = static_cast<GCOB_FP128 *>(malloc(list_size *sizeof(GCOB_FP128))); + massert(the_list); size_t k_count = 0; assert(ncount); for(size_t i=0; i<ncount; i++) @@ -2040,9 +2048,11 @@ __gg__median( cblc_field_t *dest, if(k_count >= list_size) { list_size *= 2; - the_list = (GCOB_FP128 *)realloc(the_list, list_size *sizeof(GCOB_FP128)); + the_list = PTRCAST(GCOB_FP128, realloc(the_list, list_size *sizeof(GCOB_FP128))); + massert(the_list); } + assert(the_list); the_list[k_count] = __gg__float128_from_qualified_field(__gg__treeplet_1f[i], __gg__treeplet_1o[i], __gg__treeplet_1s[i]); @@ -2125,11 +2135,11 @@ __gg__min(cblc_field_t *dest, if( ( __gg__treeplet_1f[0]->type == FldAlphanumeric || __gg__treeplet_1f[0]->type == FldLiteralA) ) { - cblc_field_t *best_field ; - unsigned char *best_location ; - size_t best_length ; - int best_attr ; - int best_flags ; + cblc_field_t *best_field ; + unsigned char *best_location = nullptr ; + size_t best_length = 0 ; + int best_attr ; + int best_flags ; bool first_time = true; assert(ncount); @@ -2189,6 +2199,7 @@ __gg__min(cblc_field_t *dest, __gg__adjust_dest_size(dest, best_length); dest->type = FldAlphanumeric; + assert(best_location); memcpy(dest->data, best_location, best_length); } else @@ -2277,15 +2288,15 @@ __gg__mod(cblc_field_t *dest, static int numval( cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { // Returns the one-based character position of a bad character // returns zero if it is okay - char *p = (char *)(input->data + input_offset); - char *pend = p + input_size; + const char *p = PTRCAST(char, (input->data + input_offset)); + const char *pend = p + input_size; int errpos = 0; __int128 retval = 0; @@ -2568,17 +2579,17 @@ numval( cblc_field_t *dest, static int numval_c( cblc_field_t *dest, - cblc_field_t *src, + const cblc_field_t *src, size_t src_offset, size_t src_size, - cblc_field_t *crcy, + const cblc_field_t *crcy, size_t crcy_offset, size_t crcy_size ) { size_t errcode = 0; - char *pstart = (char *)(src->data+src_offset); + char *pstart = PTRCAST(char, (src->data+src_offset)); char *pend = pstart + src_size; char *p = pstart; @@ -2593,7 +2604,7 @@ numval_c( cblc_field_t *dest, char *currency_end; if( crcy ) { - currency_start = (char *)(crcy->data+crcy_offset); + currency_start = PTRCAST(char, (crcy->data+crcy_offset)); currency_end = currency_start + crcy_size; } else @@ -2807,7 +2818,6 @@ numval_c( cblc_field_t *dest, if( sign ) { // A second sign isn't allowed - state = final_space; errcode = p - pstart; p = pend; } @@ -2875,7 +2885,7 @@ numval_c( cblc_field_t *dest, extern "C" void __gg__numval( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -2889,7 +2899,7 @@ __gg__numval( cblc_field_t *dest, extern "C" void __gg__test_numval(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -2904,10 +2914,10 @@ __gg__test_numval(cblc_field_t *dest, extern "C" void __gg__numval_c( cblc_field_t *dest, - cblc_field_t *src, + const cblc_field_t *src, size_t src_offset, size_t src_size, - cblc_field_t *crcy, + const cblc_field_t *crcy, size_t crcy_offset, size_t crcy_size ) @@ -2924,10 +2934,10 @@ __gg__numval_c( cblc_field_t *dest, extern "C" void __gg__test_numval_c(cblc_field_t *dest, - cblc_field_t *src, + const cblc_field_t *src, size_t src_offset, size_t src_size, - cblc_field_t *crcy, + const cblc_field_t *crcy, size_t crcy_offset, size_t crcy_size ) @@ -2949,12 +2959,12 @@ __gg__test_numval_c(cblc_field_t *dest, extern "C" void __gg__ord(cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t /*input_size*/) { // We get our input in internal_character form. - char *arg = (char *)(input->data + input_offset); + const char *arg = PTRCAST(char, (input->data + input_offset)); // The ORD function takes a single-character string and returns the // ordinal position of that character. @@ -3257,10 +3267,10 @@ __gg__range(cblc_field_t *dest, extern "C" void __gg__rem(cblc_field_t *dest, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_offset, size_t par1_size, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_offset, size_t par2_size) { @@ -3300,10 +3310,10 @@ __gg__rem(cblc_field_t *dest, extern "C" void __gg__trim( cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -3329,7 +3339,7 @@ __gg__trim( cblc_field_t *dest, // No matter what, we want to find the leftmost non-space and the // rightmost non-space: - char *left = (char *)(arg1->data+arg1_offset); + char *left = PTRCAST(char, (arg1->data+arg1_offset)); char *right = left + arg1_size-1; // Find left and right: the first and last non-spaces @@ -3352,13 +3362,13 @@ __gg__trim( cblc_field_t *dest, { // We want to leave any trailing spaces, so we return 'right' to its // original value: - right = (char *)(arg1->data+arg1_offset) + arg1_size-1; + right = PTRCAST(char, (arg1->data+arg1_offset)) + arg1_size-1; } else if( type == TRAILING ) { // We want to leave any leading spaces, so we return 'left' to its // original value: - left = (char *)(arg1->data+arg1_offset); + left = PTRCAST(char, (arg1->data+arg1_offset)); } if( left > right ) @@ -3378,9 +3388,9 @@ __gg__trim( cblc_field_t *dest, // compiler believes the capacity to be at compile-time. But we obviously // think it'll be okay. - char *dest_left = (char *)dest->data; + char *dest_left = PTRCAST(char, dest->data); char *dest_right = dest_left + dest->capacity - 1; - char *dest_end = dest_left + dest->capacity; + const char *dest_end = dest_left + dest->capacity; while( dest_left <= dest_right && left <= right ) { @@ -3403,7 +3413,7 @@ static unsigned seed = 0; extern "C" void __gg__random( cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { @@ -3422,7 +3432,7 @@ __gg__random( cblc_field_t *dest, buf->state = NULL; state = (char *)malloc(state_len); - struct timespec ts; + struct cbl_timespec ts; __gg__clock_gettime(CLOCK_REALTIME, &ts); initstate_r( ts.tv_nsec, state, state_len, buf); } @@ -3462,7 +3472,7 @@ __gg__random_next(cblc_field_t *dest) buf = (random_data *)malloc(sizeof(struct random_data)); buf->state = NULL; state = (char *)malloc(state_len); - struct timespec ts; + struct cbl_timespec ts; __gg__clock_gettime(CLOCK_REALTIME, &ts); initstate_r( ts.tv_nsec, state, state_len, buf); } @@ -3480,7 +3490,7 @@ __gg__random_next(cblc_field_t *dest) extern "C" void __gg__reverse(cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { @@ -3501,7 +3511,7 @@ __gg__reverse(cblc_field_t *dest, extern "C" void __gg__sign( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3534,7 +3544,7 @@ __gg__sign( cblc_field_t *dest, extern "C" void __gg__sin(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3555,7 +3565,7 @@ __gg__sin(cblc_field_t *dest, extern "C" void __gg__sqrt( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3621,7 +3631,7 @@ __gg__sum(cblc_field_t *dest, extern "C" void __gg__tan(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3640,7 +3650,7 @@ __gg__tan(cblc_field_t *dest, extern "C" void __gg__test_date_yyyymmdd( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3650,14 +3660,8 @@ __gg__test_date_yyyymmdd( cblc_field_t *dest, source_offset, source_size); int retval; - int dd = yyyymmdd % 100; int mmdd = yyyymmdd % 10000; int mm = mmdd / 100; - int yyyy = yyyymmdd / 10000; - int jy; - int jm; - int jd; - double JD; if( yyyymmdd < 16010000 || yyyymmdd > 99999999 ) { retval = 1; @@ -3668,6 +3672,13 @@ __gg__test_date_yyyymmdd( cblc_field_t *dest, } else { + int dd = yyyymmdd % 100; + int yyyy = yyyymmdd / 10000; + int jy; + int jm; + int jd; + double JD; + // If there is something wrong with the number of days per month for a // given year, the Julian Date conversion won't reverse properly. // For example, January 32 will come back as February 1 @@ -3692,7 +3703,7 @@ __gg__test_date_yyyymmdd( cblc_field_t *dest, extern "C" void __gg__test_day_yyyyddd( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3730,7 +3741,7 @@ __gg__test_day_yyyyddd( cblc_field_t *dest, extern "C" void __gg__upper_case( cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { @@ -3738,10 +3749,10 @@ __gg__upper_case( cblc_field_t *dest, size_t source_length = input_size; memset(dest->data, internal_space, dest_length); memcpy(dest->data, input->data+input_offset, std::min(dest_length, source_length)); - internal_to_ascii((char *)dest->data, dest_length); + internal_to_ascii( PTRCAST(char, dest->data), dest_length); std::transform(dest->data, dest->data + dest_length, dest->data, [](unsigned char c) { return std::toupper(c); }); - ascii_to_internal_str((char *)dest->data, dest_length); + ascii_to_internal_str( PTRCAST(char, dest->data), dest_length); } extern "C" @@ -3765,7 +3776,7 @@ extern "C" void __gg__when_compiled(cblc_field_t *dest, size_t tv_sec, long tv_nsec) { - struct timespec tp = {}; + struct cbl_timespec tp = {}; tp.tv_sec = tv_sec; tp.tv_nsec = tv_nsec; char retval[DATE_STRING_BUFFER_SIZE]; @@ -3777,13 +3788,13 @@ __gg__when_compiled(cblc_field_t *dest, size_t tv_sec, long tv_nsec) extern "C" void __gg__year_to_yyyy( cblc_field_t *dest, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_o, size_t par1_s, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_o, size_t par2_s, - cblc_field_t *par3, + const cblc_field_t *par3, size_t par3_o, size_t par3_s) { @@ -3804,7 +3815,7 @@ __gg__year_to_yyyy( cblc_field_t *dest, static int -gets_int(int ndigits, char *p, char *pend, int *digits) +gets_int(int ndigits, const char *p, const char *pend, int *digits) { // This routine returns the value of the integer at p. If there is something // wrong with the integer, it returns a negative number, the value being the @@ -3835,7 +3846,7 @@ gets_int(int ndigits, char *p, char *pend, int *digits) static int -gets_year(char *p, char *pend, struct cobol_tm &ctm) +gets_year(const char *p, const char *pend, struct cobol_tm &ctm) { // Populates ctm.YYYY, ctm.days_in_year, and ctm.weeks_in_year, which are // all determined by the YYYY value. @@ -3855,10 +3866,6 @@ gets_year(char *p, char *pend, struct cobol_tm &ctm) { return 2; } - if( digits[0] == 0 && digits[1] < 5) - { - return 2; - } if( digits[2] == -1 ) { return 3; @@ -3903,7 +3910,7 @@ gets_year(char *p, char *pend, struct cobol_tm &ctm) static int -gets_month(char *p, char *pend, struct cobol_tm &ctm) +gets_month(const char *p, const char *pend, struct cobol_tm &ctm) { // Populates ctm.MM @@ -3950,7 +3957,7 @@ gets_month(char *p, char *pend, struct cobol_tm &ctm) static int -gets_day(char *p, char *pend, struct cobol_tm &ctm) +gets_day(const char *p, const char *pend, struct cobol_tm &ctm) { // Populates ctm.DD, ctm.day_of_week, ctm.week_of_year, ctm.day_of_week @@ -3968,48 +3975,45 @@ gets_day(char *p, char *pend, struct cobol_tm &ctm) { return 2; } - if(DD >= 0) + if( DD >= 0 ) { - if( DD >= 0 ) + if( DD == 0) { - if( DD == 0) - { - // If zero, we know we failed at the second '0' in "00" - retval = 2; - } - else if( DD >= 40) + // If zero, we know we failed at the second '0' in "00" + retval = 2; + } + else if( DD >= 40) + { + // 40 or more, then we knew there was trouble at the first digit + retval = 1; + } + else if(ctm.MM == 2 && DD >=30) + { + // It's February, so if we see 3x we know on the 3 that we are in + // error: + retval = 1; + } + else + { + static const int month_days[13] = {-1,31,28,31,30,31,30,31,31,30,31,30,31}; + int days_in_month = month_days[ctm.MM]; + if( ctm.MM == 2 && ctm.days_in_year == 366 ) { - // 40 or more, then we knew there was trouble at the first digit - retval = 1; + days_in_month = 29; } - else if(ctm.MM == 2 && DD >=30) + + if( DD > days_in_month ) { - // It's February, so if we see 3x we know on the 3 that we are in - // error: - retval = 1; + retval = 2; } else { - static const int month_days[13] = {-1,31,28,31,30,31,30,31,31,30,31,30,31}; - int days_in_month = month_days[ctm.MM]; - if( ctm.MM == 2 && ctm.days_in_year == 366 ) - { - days_in_month = 29; - } - - if( DD > days_in_month ) - { - retval = 2; - } - else - { - // We have a good YYYY-MM-DD - ctm.DD = DD; - double JD = YMD_to_JD(ctm.YYYY, ctm.MM, DD); - double JD_Jan0 = YMD_to_JD(ctm.YYYY, 1, 0); - ctm.day_of_year = (int)(JD - JD_Jan0); - ctm.day_of_week = JD_to_DOW(JD); - } + // We have a good YYYY-MM-DD + ctm.DD = DD; + double JD = YMD_to_JD(ctm.YYYY, ctm.MM, DD); + double JD_Jan0 = YMD_to_JD(ctm.YYYY, 1, 0); + ctm.day_of_year = (int)(JD - JD_Jan0); + ctm.day_of_week = JD_to_DOW(JD); } } } @@ -4022,7 +4026,7 @@ gets_day(char *p, char *pend, struct cobol_tm &ctm) static int -gets_day_of_week(char *p, char *pend, struct cobol_tm &ctm) +gets_day_of_week(const char *p, const char *pend, struct cobol_tm &ctm) { // This is just a simple D, for day-of-week. The COBOL spec is that // it be 1 to 7, 1 being Monday @@ -4071,7 +4075,7 @@ gets_day_of_week(char *p, char *pend, struct cobol_tm &ctm) static int -gets_day_of_year(char *p, char *pend, struct cobol_tm &ctm) +gets_day_of_year(const char *p, const char *pend, struct cobol_tm &ctm) { // This is a three-digit day-of-year, 001 through 365,366 int digits[3]; @@ -4128,7 +4132,7 @@ gets_day_of_year(char *p, char *pend, struct cobol_tm &ctm) static int -gets_week(char *p, char *pend, struct cobol_tm &ctm) +gets_week(const char *p, const char *pend, struct cobol_tm &ctm) { // This is a two-digit value, 01 through 52,53 int digits[2]; @@ -4168,7 +4172,10 @@ gets_week(char *p, char *pend, struct cobol_tm &ctm) static int -gets_hours(char *p, char *pend, struct cobol_tm &ctm, bool in_offset) +gets_hours( const char *p, + const char *pend, + struct cobol_tm &ctm, + bool in_offset) { // This is a two-digit value, 01 through 23 int digits[2]; @@ -4213,7 +4220,10 @@ gets_hours(char *p, char *pend, struct cobol_tm &ctm, bool in_offset) static int -gets_minutes(char *p, char *pend, struct cobol_tm &ctm, bool in_offset) +gets_minutes( const char *p, + const char *pend, + struct cobol_tm &ctm, + bool in_offset) { // This is a two-digit value, 01 through 59 int digits[2]; @@ -4251,7 +4261,7 @@ gets_minutes(char *p, char *pend, struct cobol_tm &ctm, bool in_offset) static int -gets_seconds(char *p, char *pend, struct cobol_tm &ctm) +gets_seconds(const char *p, const char *pend, struct cobol_tm &ctm) { // This is a two-digit value, 01 through 59 int digits[2]; @@ -4281,7 +4291,11 @@ gets_seconds(char *p, char *pend, struct cobol_tm &ctm) static int -gets_nanoseconds(char *f, char *f_end, char *p, char *pend, struct cobol_tm &ctm) +gets_nanoseconds( const char *f, + const char *f_end, + const char *p, + const char *pend, + struct cobol_tm &ctm) { // Because nanoseconds digits to the right of the decimal point can vary from // one digit to our implementation-specific limit of nine characters, this @@ -4293,7 +4307,7 @@ gets_nanoseconds(char *f, char *f_end, char *p, char *pend, struct cobol_tm &ctm int ncount = 0; int nanoseconds = 0; - char *pinit = p; + const char *pinit = p; while( f < f_end && *f == internal_s && p < pend ) { f += 1; @@ -4325,19 +4339,19 @@ gets_nanoseconds(char *f, char *f_end, char *p, char *pend, struct cobol_tm &ctm static int fill_cobol_tm(cobol_tm &ctm, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_offset, size_t par1_size, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_offset, size_t par2_size) { // Establish the formatting string: - char *format = (char *)(par1->data+par1_offset); + char *format = PTRCAST(char, (par1->data+par1_offset)); char *format_end = format + par1_size; // Establish the string to be checked: - char *source = (char *)(par2->data+par2_offset); + char *source = PTRCAST(char, (par2->data+par2_offset)); char *source_end = source + par2_size; // Let's eliminate trailing spaces... @@ -4587,10 +4601,10 @@ proceed: extern "C" void __gg__test_formatted_datetime(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) @@ -4610,10 +4624,10 @@ __gg__test_formatted_datetime(cblc_field_t *dest, extern "C" void __gg__integer_of_formatted_date(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -4645,10 +4659,10 @@ __gg__integer_of_formatted_date(cblc_field_t *dest, extern "C" void __gg__seconds_from_formatted_time(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -4673,7 +4687,7 @@ __gg__seconds_from_formatted_time(cblc_field_t *dest, extern "C" void __gg__hex_of(cblc_field_t *dest, - cblc_field_t *field, + const cblc_field_t *field, size_t field_offset, size_t field_size) { @@ -4691,7 +4705,7 @@ __gg__hex_of(cblc_field_t *dest, extern "C" void __gg__highest_algebraic(cblc_field_t *dest, - cblc_field_t *var, + const cblc_field_t *var, size_t, size_t) { @@ -4733,7 +4747,7 @@ __gg__highest_algebraic(cblc_field_t *dest, extern "C" void __gg__lowest_algebraic( cblc_field_t *dest, - cblc_field_t *var, + const cblc_field_t *var, size_t, size_t) { @@ -4795,7 +4809,7 @@ __gg__lowest_algebraic( cblc_field_t *dest, } static int -floating_format_tester(char const * const f, char * const f_end) +floating_format_tester(char const * const f, char const * const f_end) { int retval = -1; char decimal_point = __gg__get_decimal_point(); @@ -4983,13 +4997,13 @@ floating_format_tester(char const * const f, char * const f_end) extern "C" void __gg__numval_f( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { GCOB_FP128 value = 0; - char *data = (char * )(source->data + source_offset); - char *data_end = data + source_size; + const char *data = PTRCAST(char, (source->data + source_offset)); + const char *data_end = data + source_size; int error = floating_format_tester(data, data_end); @@ -5022,12 +5036,12 @@ __gg__numval_f( cblc_field_t *dest, extern "C" void __gg__test_numval_f(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { - char *data = (char * )(source->data + source_offset); - char *data_end = data + source_size; + const char *data = PTRCAST(char, (source->data + source_offset)); + const char *data_end = data + source_size; int error = floating_format_tester(data, data_end); @@ -5039,7 +5053,7 @@ __gg__test_numval_f(cblc_field_t *dest, } static bool -ismatch(char *a1, char *a2, char *b1, char *b2) +ismatch(const char *a1, const char *a2, const char *b1, const char *b2) { bool retval = true; while( a1 < a2 && b1 < b2 ) @@ -5053,7 +5067,7 @@ ismatch(char *a1, char *a2, char *b1, char *b2) } static bool -iscasematch(char *a1, char *a2, char *b1, char *b2) +iscasematch(const char *a1, const char *a2, const char *b1, const char *b2) { bool retval = true; while( a1 < a2 && b1 < b2 ) @@ -5066,11 +5080,15 @@ iscasematch(char *a1, char *a2, char *b1, char *b2) return retval; } -static char * -strstr(char *haystack, char *haystack_e, char *needle, char *needle_e) +static +const char * +strstr( const char *haystack, + const char *haystack_e, + const char *needle, + const char *needle_e) { - char *retval = NULL; - char *pend = haystack_e - (needle_e - needle); + const char *retval = NULL; + const char *pend = haystack_e - (needle_e - needle); while( haystack <= pend ) { if(ismatch(haystack, haystack_e, needle, needle_e)) @@ -5083,11 +5101,15 @@ strstr(char *haystack, char *haystack_e, char *needle, char *needle_e) return retval; } -static char * -strcasestr(char *haystack, char *haystack_e, char *needle, char *needle_e) +static +const char * +strcasestr( const char *haystack, + const char *haystack_e, + const char *needle, + const char *needle_e) { - char *retval = NULL; - char *pend = haystack_e - (needle_e - needle); + const char *retval = NULL; + const char *pend = haystack_e - (needle_e - needle); while( haystack <= pend ) { if(iscasematch(haystack, haystack_e, needle, needle_e)) @@ -5100,11 +5122,15 @@ strcasestr(char *haystack, char *haystack_e, char *needle, char *needle_e) return retval; } -static char * -strlaststr(char *haystack, char *haystack_e, char *needle, char *needle_e) +static +const char * +strlaststr( const char *haystack, + const char *haystack_e, + const char *needle, + const char *needle_e) { - char *retval = NULL; - char *pend = haystack_e - (needle_e - needle); + const char *retval = NULL; + const char *pend = haystack_e - (needle_e - needle); while( haystack <= pend ) { if(ismatch(haystack, haystack_e, needle, needle_e)) @@ -5116,11 +5142,15 @@ strlaststr(char *haystack, char *haystack_e, char *needle, char *needle_e) return retval; } -static char * -strcaselaststr(char *haystack, char *haystack_e, char *needle, char *needle_e) +static +const char * +strcaselaststr( const char *haystack, + const char *haystack_e, + const char *needle, + const char *needle_e) { - char *retval = NULL; - char *pend = haystack_e - (needle_e - needle); + const char *retval = NULL; + const char *pend = haystack_e - (needle_e - needle); while( haystack <= pend ) { if(iscasematch(haystack, haystack_e, needle, needle_e)) @@ -5134,13 +5164,13 @@ strcaselaststr(char *haystack, char *haystack_e, char *needle, char *needle_e) extern "C" -void __gg__substitute(cblc_field_t *dest, - cblc_field_t *arg1_f, - size_t arg1_o, - size_t arg1_s, - size_t N, - uint8_t *control - ) +void +__gg__substitute( cblc_field_t *dest, + const cblc_field_t *arg1_f, + size_t arg1_o, + size_t arg1_s, + size_t N, + const uint8_t *control) { // arg2 is the Group 1 triplet. // arg3 is the Group 2 triplet @@ -5148,19 +5178,22 @@ void __gg__substitute(cblc_field_t *dest, size_t *arg2_o = __gg__treeplet_1o; size_t *arg2_s = __gg__treeplet_1s; cblc_field_t **arg3_f = __gg__treeplet_2f; - size_t *arg3_o = __gg__treeplet_2o; - size_t *arg3_s = __gg__treeplet_2s; + const size_t *arg3_o = __gg__treeplet_2o; + const size_t *arg3_s = __gg__treeplet_2s; - ssize_t retval_size = 256; - char *retval = (char *)malloc(retval_size); + ssize_t retval_size; + retval_size = 256; + char *retval = static_cast<char *>(malloc(retval_size)); + massert(retval); *retval = '\0'; - char *haystack = (char *)(arg1_f->data + arg1_o); - char *haystack_e = haystack + arg1_s; + const char *haystack = PTRCAST(char, (arg1_f->data + arg1_o)); + const char *haystack_e = haystack + arg1_s; ssize_t outdex = 0; - char **pflasts = (char **)malloc(N * sizeof(char *)); + const char **pflasts = static_cast<const char **>(malloc(N * sizeof(char *))); + massert(pflasts); if( arg1_s == 0 ) { @@ -5181,15 +5214,15 @@ void __gg__substitute(cblc_field_t *dest, { pflasts[i] = strcasestr(haystack, haystack_e, - (char *)(arg2_f[i]->data+arg2_o[i]), - (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]); + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])), + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])) + arg2_s[i]); } else if( control[i] & substitute_last_e) { pflasts[i] = strcaselaststr(haystack, haystack_e, - (char *)(arg2_f[i]->data+arg2_o[i]), - (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]); + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])), + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])) + arg2_s[i]); } else { @@ -5202,15 +5235,15 @@ void __gg__substitute(cblc_field_t *dest, { pflasts[i] = strstr(haystack, haystack_e, - (char *)(arg2_f[i]->data+arg2_o[i]), - (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]); + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])), + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])) + arg2_s[i]); } else if( control[i] & substitute_last_e) { pflasts[i] = strlaststr(haystack, haystack_e, - (char *)(arg2_f[i]->data+arg2_o[i]), - (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]); + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])), + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])) + arg2_s[i]); } else { @@ -5230,7 +5263,8 @@ void __gg__substitute(cblc_field_t *dest, > retval_size ) { retval_size *= 2; - retval = (char *)realloc(retval, retval_size); + retval = static_cast<char *>(realloc(retval, retval_size)); + massert(retval); } // We checked earlier for FIRST/LAST matches @@ -5245,8 +5279,8 @@ void __gg__substitute(cblc_field_t *dest, continue; } - char *needle = (char *)(arg2_f[i]->data+arg2_o[i]); - char *needle_e = (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]; + const char *needle = PTRCAST(char, arg2_f[i]->data+arg2_o[i]); + const char *needle_e = PTRCAST(char, arg2_f[i]->data+arg2_o[i]) + arg2_s[i]; matched = (control[i] & substitute_anycase_e) && iscasematch( haystack, haystack_e, @@ -5274,7 +5308,8 @@ void __gg__substitute(cblc_field_t *dest, while( outdex + 1 > retval_size ) { retval_size *= 2; - retval = (char *)realloc(retval, retval_size); + retval = static_cast<char *>(realloc(retval, retval_size)); + massert(retval); } retval[outdex++] = *haystack++; } @@ -5291,13 +5326,13 @@ void __gg__substitute(cblc_field_t *dest, extern "C" void __gg__locale_compare( cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_o, size_t arg1_s, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_o, size_t arg2_s, - cblc_field_t *arg_locale, + const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/ ) @@ -5348,10 +5383,10 @@ __gg__locale_compare( cblc_field_t *dest, extern "C" void __gg__locale_date(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_o, size_t /*arg1_s*/, - cblc_field_t *arg_locale, + const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/) { @@ -5384,10 +5419,10 @@ __gg__locale_date(cblc_field_t *dest, extern "C" void __gg__locale_time(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_o, size_t /*arg1_s*/, - cblc_field_t *arg_locale, + const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/) @@ -5420,10 +5455,10 @@ __gg__locale_time(cblc_field_t *dest, extern "C" void __gg__locale_time_from_seconds( cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_o, size_t arg1_s, - cblc_field_t *arg_locale, + const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/) { @@ -5439,7 +5474,7 @@ __gg__locale_time_from_seconds( cblc_field_t *dest, // Default locale tm tm = {}; - int rdigits; + int rdigits=0; long seconds = (long)__gg__binary_value_from_qualified_field(&rdigits, arg1, arg1_o, diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 3ab7463..e89ca0a 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -65,14 +65,11 @@ #include "gfileio.h" #include "charmaps.h" #include "valconv.h" - #include <sys/mman.h> #include <sys/resource.h> #include <sys/stat.h> #include <sys/types.h> - #include <execinfo.h> - #include "exceptl.h" /* BSD extension. */ @@ -196,7 +193,7 @@ size_t __gg__unique_prog_id = 0 ; // location information are established in the "last_exception..." variables. // This is in accordance with the ISO requirements of "14.6.13.1.1 General" that // describe how a "last exception status" is maintained. -// other "location" information +// other "location" information static int last_exception_code; static const char *last_exception_program_id; static const char *last_exception_section; @@ -240,36 +237,43 @@ void *__gg__exit_address = NULL; * 4. handled, where handled == type * * If the statement includes some kind of ON ERROR - * clause that covers it, the generated code does not raise an EC. + * clause that covers it, the generated code does not raise an EC. * * The status is updated by __gg_match_exception if it runs, else - * __gg__check_fatal_exception. + * __gg__check_fatal_exception. * * If a Declarative is matched, its section number is passed to handled_by(), * which does two things: * 1. sets isection to record the declarative * 2. for a nonfatal EC, sets handled, indication no further action is needed * - * A Declarative may use RESUME, which clears ec_status, which is a "handled" state. - * - * Default processing ensures return to initial state. + * A Declarative may use RESUME, which clears ec_status, which is a "handled" state. + * + * Default processing ensures return to initial state. */ class ec_status_t { public: struct file_status_t { - size_t ifile; - cblc_file_prior_op_t operation; - cbl_file_mode_t mode; + size_t ifile; + cblc_file_prior_op_t operation; + cbl_file_mode_t mode; cblc_field_t *user_status; const char * filename; - file_status_t() : ifile(0) , operation(file_op_none), mode(file_mode_none_e) {} - file_status_t( cblc_file_t *file ) - : ifile(file->symbol_table_index) - , operation(file->prior_op) - , mode(cbl_file_mode_t(file->mode_char)) - , user_status(file->user_status) - , filename(file->filename) - {} + file_status_t() + : ifile(0) + , operation(file_op_none) + , mode(file_mode_none_e) + , user_status(nullptr) + , filename(nullptr) + {} +// cppcheck-suppress noExplicitConstructor + file_status_t( const cblc_file_t *file ) + : ifile(file->symbol_table_index) + , operation(file->prior_op) + , mode(cbl_file_mode_t(file->mode_char)) + , user_status(file->user_status) + , filename(file->filename) + {} const char * op_str() const { switch( operation ) { case file_op_none: return "none"; @@ -284,7 +288,7 @@ class ec_status_t { return "???"; } }; - private: + private: char msg[132]; ec_type_t type, handled; size_t isection; @@ -308,13 +312,13 @@ class ec_status_t { bool is_fatal() const; ec_status_t& update(); - + bool is_enabled() const { return enabled.match(type); } bool is_enabled( ec_type_t ec) const { return enabled.match(ec); } ec_status_t& handled_by( size_t declarative_section ) { isection = declarative_section; - // A fatal exception remains unhandled unless RESUME clears it. - if( ! is_fatal() ) { + // A fatal exception remains unhandled unless RESUME clears it. + if( ! is_fatal() ) { handled = type; } return *this; @@ -326,10 +330,10 @@ class ec_status_t { return *this; } bool unset() const { return isection == 0 && lineno == 0; } - + void reset_environment() const; ec_status_t& copy_environment(); - + // Return the EC's type if it is *not* handled. ec_type_t unhandled() const { bool was_handled = ec_cmp(type, handled); @@ -428,8 +432,17 @@ ec_status_t::reset_environment() const { ::declaratives = declaratives; } + +// This is the default truncation mode static cbl_truncation_mode truncation_mode = trunc_std_e; +extern "C" +void +__gg__set_truncation_mode(cbl_truncation_mode trunc_mode) + { + truncation_mode = trunc_mode; + } + struct program_state { // These are the run-time values of these characters. @@ -535,7 +548,6 @@ void *malloc(size_t a) void *retval = malloc(a); fprintf(stderr, " --malloc(%p)-- ", retval); return retval; - return retval; } #endif @@ -546,6 +558,12 @@ __gg__abort(const char *msg) abort(); } +void +__gg__mabort() + { + __gg__abort("Memory allocation error\n"); + } + extern "C" char __gg__get_decimal_point() @@ -576,7 +594,7 @@ __gg__resize_int_p( size_t *size, if( new_size > *size ) { *size = new_size; - *block = (int *)realloc(*block, new_size * sizeof(int)); + *block = static_cast<int *>(realloc(*block, new_size * sizeof(int))); } } @@ -591,36 +609,36 @@ __gg__resize_treeplet(int ngroup, if( new_size > treeplet_1_size ) { treeplet_1_size = new_size; - __gg__treeplet_1f = (cblc_field_t **)realloc(__gg__treeplet_1f, new_size * sizeof(cblc_field_t *)); - __gg__treeplet_1o = (size_t *)realloc(__gg__treeplet_1o, new_size * sizeof(size_t)); - __gg__treeplet_1s = (size_t *)realloc(__gg__treeplet_1s, new_size * sizeof(size_t)); + __gg__treeplet_1f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_1f, new_size * sizeof(cblc_field_t *))); + __gg__treeplet_1o = static_cast<size_t *>(realloc(__gg__treeplet_1o, new_size * sizeof(size_t))); + __gg__treeplet_1s = static_cast<size_t *>(realloc(__gg__treeplet_1s, new_size * sizeof(size_t))); } break; case 2: if( new_size > treeplet_2_size ) { treeplet_2_size = new_size; - __gg__treeplet_2f = (cblc_field_t **)realloc(__gg__treeplet_2f, new_size * sizeof(cblc_field_t *)); - __gg__treeplet_2o = (size_t *)realloc(__gg__treeplet_2o, new_size * sizeof(size_t)); - __gg__treeplet_2s = (size_t *)realloc(__gg__treeplet_2s, new_size * sizeof(size_t)); + __gg__treeplet_2f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_2f, new_size * sizeof(cblc_field_t *))); + __gg__treeplet_2o = static_cast<size_t *>(realloc(__gg__treeplet_2o, new_size * sizeof(size_t))); + __gg__treeplet_2s = static_cast<size_t *>(realloc(__gg__treeplet_2s, new_size * sizeof(size_t))); } break; case 3: if( new_size > treeplet_3_size ) { treeplet_3_size = new_size; - __gg__treeplet_3f = (cblc_field_t **)realloc(__gg__treeplet_3f, new_size * sizeof(cblc_field_t *)); - __gg__treeplet_3o = (size_t *)realloc(__gg__treeplet_3o, new_size * sizeof(size_t)); - __gg__treeplet_3s = (size_t *)realloc(__gg__treeplet_3s, new_size * sizeof(size_t)); + __gg__treeplet_3f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_3f, new_size * sizeof(cblc_field_t *))); + __gg__treeplet_3o = static_cast<size_t *>(realloc(__gg__treeplet_3o, new_size * sizeof(size_t))); + __gg__treeplet_3s = static_cast<size_t *>(realloc(__gg__treeplet_3s, new_size * sizeof(size_t))); } break; case 4: if( new_size > treeplet_4_size ) { treeplet_4_size = new_size; - __gg__treeplet_4f = (cblc_field_t **)realloc(__gg__treeplet_4f, new_size * sizeof(cblc_field_t *)); - __gg__treeplet_4o = (size_t *)realloc(__gg__treeplet_4o, new_size * sizeof(size_t)); - __gg__treeplet_4s = (size_t *)realloc(__gg__treeplet_4s, new_size * sizeof(size_t)); + __gg__treeplet_4f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_4f, new_size * sizeof(cblc_field_t *))); + __gg__treeplet_4o = static_cast<size_t *>(realloc(__gg__treeplet_4o, new_size * sizeof(size_t))); + __gg__treeplet_4s = static_cast<size_t *>(realloc(__gg__treeplet_4s, new_size * sizeof(size_t))); } break; } @@ -738,7 +756,7 @@ __gg__init_program_state() } static int -var_is_refmod( cblc_field_t *var ) +var_is_refmod( const cblc_field_t *var ) { return (var->attr & refmod_e) != 0; } @@ -907,9 +925,9 @@ __gg__binary_to_string_internal(char *result, int digits, __int128 value) } static bool -value_is_too_big( cblc_field_t *var, - __int128 value, - int source_rdigits) +value_is_too_big(const cblc_field_t *var, + __int128 value, + int source_rdigits) { // This routine is in support of arithmetic ON SIZE ERROR. It returns // TRUE if var hasn't enough bytes to hold the decimal representation @@ -1046,12 +1064,13 @@ is_sign_bit_on(char ch) extern "C" void -__gg__string_to_alpha_edited_ascii( char *dest, - char *source, - int slength, - char *picture) +__gg__string_to_alpha_edited_ascii( char *dest, + const char *source, + int slength, + const char *picture) { - char *dupe = (char *)malloc(slength); + char *dupe = static_cast<char *>(malloc(slength)); + massert(dupe); memcpy(dupe, source, slength); ascii_to_internal_str(dupe, slength); __gg__string_to_alpha_edited(dest, dupe, slength, picture); @@ -1406,7 +1425,7 @@ int128_to_field(cblc_field_t *var, { float tvalue = (float)value; tvalue /= (float)__gg__power_of_ten(source_rdigits); - *(float *)location = tvalue; + *PTRCAST(float, location) = tvalue; break; } @@ -1414,7 +1433,7 @@ int128_to_field(cblc_field_t *var, { double tvalue = (double)value; tvalue /= (double)__gg__power_of_ten(source_rdigits); - *(double *)location = tvalue; + *PTRCAST(double, location) = tvalue; break; } @@ -1478,8 +1497,6 @@ int128_to_field(cblc_field_t *var, default: { - bool size_error = false; - int target_rdigits = var->rdigits; if( var->attr & intermediate_e && var->type == FldNumericBin5) { @@ -1569,6 +1586,7 @@ int128_to_field(cblc_field_t *var, else { // Value is now scaled to the target's target_rdigits + bool size_error = false; int is_negative = value < 0 ; @@ -1598,8 +1616,9 @@ int128_to_field(cblc_field_t *var, // Note that sending a signed value to an alphanumeric strips off // any plus or minus signs. - size_error = __gg__binary_to_string_internal( (char *)location, - length, value); + size_error = __gg__binary_to_string_internal( + PTRCAST(char, location), + length, value); break; case FldNumericDisplay: @@ -1615,7 +1634,7 @@ int128_to_field(cblc_field_t *var, { // The sign character goes into the first location size_error = - __gg__binary_to_string_internal((char *)(location+1), + __gg__binary_to_string_internal(PTRCAST(char, location+1), length-1, value); location[0] = sign_ch; } @@ -1623,8 +1642,8 @@ int128_to_field(cblc_field_t *var, { // The sign character goes into the last location size_error = - __gg__binary_to_string_internal( (char *)location, - length-1, value); + __gg__binary_to_string_internal(PTRCAST(char, location), + length-1, value); location[length-1] = sign_ch; } } @@ -1633,7 +1652,7 @@ int128_to_field(cblc_field_t *var, // The sign information is not separate, so we put it into // the number size_error = - __gg__binary_to_string_internal(( char *)location, + __gg__binary_to_string_internal(PTRCAST(char, location), length, value); if( size_error && is_negative ) @@ -1669,7 +1688,8 @@ int128_to_field(cblc_field_t *var, else { // It's a simple positive number - size_error = __gg__binary_to_string_internal( (char *)location, + size_error = __gg__binary_to_string_internal( PTRCAST(char, + location), length, value); } @@ -1692,12 +1712,12 @@ int128_to_field(cblc_field_t *var, // Convert that string according to the PICTURE clause size_error |= __gg__string_to_numeric_edited( - (char *)location, + PTRCAST(char, location), ach, target_rdigits, is_negative, var->picture); - ascii_to_internal_str((char *)location, var->capacity); + ascii_to_internal_str( PTRCAST(char, location), var->capacity); } break; @@ -1733,7 +1753,7 @@ int128_to_field(cblc_field_t *var, // Convert that string according to the PICTURE clause __gg__string_to_alpha_edited( - (char *)location, + PTRCAST(char, location), ach, strlen(ach), var->picture); @@ -1849,11 +1869,11 @@ int128_to_field(cblc_field_t *var, } static __int128 -edited_to_binary( const char *ps_, +edited_to_binary( char *ps_, int length, int *rdigits) { - const unsigned char *ps = (const unsigned char *)ps_; + const unsigned char *ps = const_cast<const unsigned char *>(PTRCAST(unsigned char, ps_)); // This routine is used for converting NumericEdited strings to // binary. @@ -1879,8 +1899,6 @@ edited_to_binary( const char *ps_, __int128 result = 0; - unsigned char ch; - // We need to check the last two characters. If CR or DB, then the result // is negative: if( length >= 2) @@ -1901,7 +1919,7 @@ edited_to_binary( const char *ps_, while( index < length ) { - ch = ps[index++] & 0xFF; + unsigned char ch = ps[index++] & 0xFF; if( ch == ascii_to_internal(__gg__decimal_point) ) { delta_r = 1; @@ -1923,11 +1941,7 @@ edited_to_binary( const char *ps_, } } - if( result == 0 ) - { - hyphen = 0; - } - else if( hyphen ) + if( hyphen ) { result = -result; } @@ -1957,7 +1971,7 @@ big_endian_to_binary_signed( } // move the bytes of psource into retval, flipping them end-to-end - unsigned char *dest = (unsigned char *)&retval; + unsigned char *dest = PTRCAST(unsigned char, &retval); while(capacity > 0) { *dest++ = psource[--capacity]; @@ -2021,7 +2035,7 @@ big_endian_to_binary_unsigned( __int128 retval = 0 ; // move the bytes of psource into retval, flipping them end-to-end - unsigned char *dest = (unsigned char *)&retval; + unsigned char *dest = PTRCAST(unsigned char, &retval); while(capacity > 0) { *dest++ = psource[--capacity]; @@ -2031,10 +2045,10 @@ big_endian_to_binary_unsigned( static __int128 -get_binary_value_local( int *rdigits, - cblc_field_t *resolved_var, - unsigned char *resolved_location, - size_t resolved_length) +get_binary_value_local( int *rdigits, + const cblc_field_t *resolved_var, + unsigned char *resolved_location, + size_t resolved_length) { __int128 retval = 0; @@ -2055,7 +2069,8 @@ get_binary_value_local( int *rdigits, case FldGroup : case FldAlphanumeric : // Read the data area as a dirty string: - retval = __gg__dirty_to_binary_internal( (const char *)resolved_location, + retval = __gg__dirty_to_binary_internal( PTRCAST(const char, + resolved_location), resolved_length, rdigits ); break; @@ -2082,8 +2097,8 @@ get_binary_value_local( int *rdigits, // Turn all the bits on memset( &retval, 0xFF, sizeof(retval) ); - // Make it positive - ((unsigned char *)&retval)[sizeof(retval)-1] = 0x3F; + // Make it positive by turning off the highest order bit: + (PTRCAST(unsigned char, &retval))[sizeof(retval)-1] = 0x3F; *rdigits = resolved_var->rdigits; } else @@ -2120,7 +2135,8 @@ get_binary_value_local( int *rdigits, // We know where the decimal point is because of rdigits. Because // we know that it a clean string of ASCII digits, we can use the // dirty converter: - retval = __gg__dirty_to_binary_internal((const char *)resolved_location, + retval = __gg__dirty_to_binary_internal(PTRCAST(const char, + resolved_location), resolved_length, rdigits ); *rdigits = resolved_var->rdigits; @@ -2136,7 +2152,7 @@ get_binary_value_local( int *rdigits, break; case FldNumericEdited : - retval = edited_to_binary( (const char *)resolved_location, + retval = edited_to_binary( PTRCAST(char, resolved_location), resolved_length, rdigits); break; @@ -2145,13 +2161,13 @@ get_binary_value_local( int *rdigits, if( resolved_var->attr & signable_e) { retval = big_endian_to_binary_signed( - (const unsigned char *)resolved_location, + PTRCAST(const unsigned char, resolved_location), resolved_length); } else { retval = big_endian_to_binary_unsigned( - (const unsigned char *)resolved_location, + PTRCAST(const unsigned char, resolved_location), resolved_length); } *rdigits = resolved_var->rdigits; @@ -2179,13 +2195,13 @@ get_binary_value_local( int *rdigits, if( resolved_var->attr & signable_e) { retval = little_endian_to_binary_signed( - (const unsigned char *)resolved_location, + PTRCAST(const unsigned char, resolved_location), resolved_length); } else { retval = little_endian_to_binary_unsigned( - (const unsigned char *)resolved_location, + PTRCAST(const unsigned char, resolved_location), resolved_length); } *rdigits = resolved_var->rdigits; @@ -2273,7 +2289,7 @@ get_binary_value_local( int *rdigits, static time_t cobol_time() { - struct timespec tp; + struct cbl_timespec tp; __gg__clock_gettime(CLOCK_REALTIME, &tp); return tp.tv_sec; } @@ -2285,7 +2301,7 @@ __gg__get_date_yymmdd() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%2.2d%2.2d%2.2d", @@ -2304,7 +2320,7 @@ __gg__get_date_yyyymmdd() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%4.4d%2.2d%2.2d", @@ -2323,7 +2339,7 @@ __gg__get_date_yyddd() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%2.2d%3.3d", @@ -2341,7 +2357,7 @@ __gg__get_yyyyddd() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%4.4d%3.3d", @@ -2359,7 +2375,7 @@ __gg__get_date_dow() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%1.1d", @@ -2386,10 +2402,32 @@ int_from_digits(const char * &p, int ndigits) return retval; } +uint64_t +get_time_nanoseconds() +{ + // This code was unabashedly stolen from gcc/timevar.cc. + // It returns the Unix epoch with nine decimal places. + + uint64_t retval = 0; + +#ifdef HAVE_CLOCK_GETTIME + struct timespec ts; + clock_gettime (CLOCK_REALTIME, &ts); + retval = ts.tv_sec * 1000000000 + ts.tv_nsec; + return retval; +#endif +#ifdef HAVE_GETTIMEOFDAY + struct timeval tv; + gettimeofday (&tv, NULL); + retval = tv.tv_sec * 1000000000 + tv.tv_usec * 1000; + return retval; +#endif + return retval; +} extern "C" void -__gg__clock_gettime(clockid_t clk_id, struct timespec *tp) +__gg__clock_gettime(clockid_t clk_id, struct cbl_timespec *tp) { const char *p = getenv("GCOBOL_CURRENT_DATE"); @@ -2419,7 +2457,11 @@ __gg__clock_gettime(clockid_t clk_id, struct timespec *tp) } else { - clock_gettime(clk_id, tp); + timespec tm; + clock_gettime(clk_id, &tm); + uint64_t ns = get_time_nanoseconds(); + tp->tv_sec = ns/1000000000; + tp->tv_nsec = ns%1000000000; } } @@ -2429,7 +2471,7 @@ __gg__get_date_hhmmssff() { char ach[32]; - struct timespec tv; + struct cbl_timespec tv; __gg__clock_gettime(CLOCK_REALTIME, &tv); struct tm tm; @@ -2459,20 +2501,19 @@ int __gg__setop_compare( const char *candidate, int capacity, - const char *domain) + char *domain) { // This routine is called to compare the characters of 'candidate' // against the list of character pairs in 'domain' int retval = 0; - int ch; int l; int h; - const char *d; + char *d; for(int i=0; i<capacity; i++) { - ch = (*candidate++ & 0xFF); + int ch = (*candidate++ & 0xFF); d = domain; while(*d) { @@ -2484,7 +2525,7 @@ __gg__setop_compare( // See the comments in genapi.cc::get_class_condition_string // to see how this string was encoded. - l = (int)strtoll(d, (char **)&d, 16); + l = (int)strtoll(d, reinterpret_cast<char **>(&d), 16); if( l < 0 ) { l = -l; @@ -2493,7 +2534,7 @@ __gg__setop_compare( if( *d == '/' ) { d += 1; - h = (int)strtoll(d, (char **)&d, 16); + h = (int)strtoll(d, reinterpret_cast<char **>(&d), 16); if( h < 0 ) { h = -h; @@ -2943,7 +2984,7 @@ void psz_to_internal(char *psz) } static int -get_scaled_rdigits(cblc_field_t *field) +get_scaled_rdigits(const cblc_field_t *field) { int retval; if( !(field->attr & scaled_e) ) @@ -3048,7 +3089,7 @@ format_for_display_internal(char **dest, break; } - unsigned char *running_location = actual_location; + const unsigned char *running_location = actual_location; // We need the counts of digits to the left and right of the decimal point int rdigits = get_scaled_rdigits(var); @@ -3063,7 +3104,6 @@ format_for_display_internal(char **dest, rdigits += ldigits; } - int index = 0; // This is the running index into our output destination if( rdigits ) { // We need room for the inside decimal point @@ -3080,6 +3120,7 @@ format_for_display_internal(char **dest, if( actual_location ) { + int index = 0; // This is the running index into our output destination if( var->attr & signable_e ) { if( var->attr & separate_e ) @@ -3124,7 +3165,7 @@ format_for_display_internal(char **dest, // the user. if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE ) { - turn_sign_bit_off((unsigned char *)&ch); + turn_sign_bit_off( PTRCAST(unsigned char, &ch)); } (*dest)[index++] = ch; } @@ -3148,7 +3189,7 @@ format_for_display_internal(char **dest, char ch = *running_location++; if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE ) { - turn_sign_bit_off((unsigned char *)&ch); + turn_sign_bit_off(PTRCAST(unsigned char, &ch)); } (*dest)[index++] = ch; } @@ -3257,11 +3298,9 @@ format_for_display_internal(char **dest, } __gg__realloc_if_necessary(dest, dest_size, nsize); - bool is_signed = value < 0; - if( var->attr & signable_e ) { - if( is_signed ) + if( value < 0 ) { (*dest)[index++] = internal_minus; } @@ -3293,7 +3332,7 @@ format_for_display_internal(char **dest, actual_location, actual_length); char ach[64]; - sprintf(ach, "%lu", (size_t)value); + sprintf(ach, "%lu", (unsigned long)value); __gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1); strcpy(*dest, ach); } @@ -3349,7 +3388,7 @@ format_for_display_internal(char **dest, // side, and 9999999 and then 1E+7 on the high side // 10,000,000 = 1E7 char ach[64]; - _Float32 floatval = *(_Float32 *)actual_location; + _Float32 floatval = *PTRCAST(_Float32, actual_location); strfromf32(ach, sizeof(ach), "%.9E", floatval); char *p = strchr(ach, 'E'); if( !p ) @@ -3389,7 +3428,7 @@ format_for_display_internal(char **dest, // We will also format numbers so that we produce 0.01 and 1E-3 on the low // side, and 9999999 and then 1E+15 on the high side char ach[64]; - _Float64 floatval = *(_Float64 *)actual_location; + _Float64 floatval = *PTRCAST(_Float64, actual_location); strfromf64(ach, sizeof(ach), "%.17E", floatval); char *p = strchr(ach, 'E'); if( !p ) @@ -3483,7 +3522,8 @@ format_for_display_internal(char **dest, if( var->attr & scaled_e && var->type != FldNumericDisplay ) { static size_t buffer_size = MINIMUM_ALLOCATION_SIZE; - static char * buffer = (char *)malloc(buffer_size); + static char *buffer = static_cast<char *>(malloc(buffer_size)); + massert(buffer); if( var->rdigits > 0) { // We have something like 123 or +123. We need to insert a decimal @@ -3542,7 +3582,7 @@ format_for_display_internal(char **dest, { p2 += 1; } - strcpy((char *)p1, (char *)p2); + strcpy(PTRCAST(char, p1), PTRCAST(char, p2)); } done: @@ -3591,7 +3631,8 @@ compare_88( const char *list, { // We are working with a figurative constant - test = (char *)malloc(conditional_length); + test = static_cast<char *>(malloc(conditional_length)); + massert(test); test_len = conditional_length; // This is where we handle the zero-length strings that // nonetheless can magically be expanded into figurative @@ -3628,14 +3669,16 @@ compare_88( const char *list, else if( list_len < conditional_length ) { // 'list' is too short; we have to right-fill with spaces: - test = (char *)malloc(conditional_length); + test = static_cast<char *>(malloc(conditional_length)); + massert(test); test_len = conditional_length; memset(test, internal_space, conditional_length); memcpy(test, list, list_len); } else { - test = (char *)malloc(list_len); + test = static_cast<char *>(malloc(list_len)); + massert(test); test_len = list_len; memcpy(test, list, list_len); } @@ -3648,7 +3691,9 @@ compare_88( const char *list, } else { - cmpval = cstrncmp(test, (char *)conditional_location, conditional_length); + cmpval = cstrncmp (test, + PTRCAST(char, conditional_location), + conditional_length); if( cmpval == 0 && (int)strlen(test) != conditional_length ) { // When strncmp returns 0, the actual smaller string is the @@ -3671,7 +3716,7 @@ compare_88( const char *list, } static GCOB_FP128 -get_float128( cblc_field_t *field, +get_float128( const cblc_field_t *field, unsigned char *location ) { GCOB_FP128 retval=0; @@ -3680,10 +3725,10 @@ get_float128( cblc_field_t *field, switch( field->capacity ) { case 4: - retval = *(_Float32 *)location; + retval = *PTRCAST(_Float32 , location); break; case 8: - retval = *(_Float64 *)location; + retval = *PTRCAST(_Float64 , location); break; case 16: // retval = *(_Float128 *)location; doesn't work, because the SSE @@ -3703,12 +3748,13 @@ get_float128( cblc_field_t *field, { // We need to replace any commas with periods static size_t size = 128; - static char *buffer = (char *)malloc(size); + static char *buffer = static_cast<char *>(malloc(size)); while( strlen(field->initial)+1 > size ) { size *= 2; - buffer = (char *)malloc(size); + buffer = static_cast<char *>(malloc(size)); } + massert(buffer); strcpy(buffer, field->initial); char *p = strchr(buffer, ','); if(p) @@ -3753,7 +3799,7 @@ compare_field_class(cblc_field_t *conditional, conditional, conditional_location, conditional_length); - char *walker = list->initial; + const char *walker = list->initial; while(*walker) { char left_flag; @@ -3899,8 +3945,8 @@ compare_field_class(cblc_field_t *conditional, case FldFloat: { - GCOB_FP128 value = get_float128(conditional, conditional_location) ; - char *walker = list->initial; + GCOB_FP128 fp128 = get_float128(conditional, conditional_location) ; + const char *walker = list->initial; while(*walker) { char left_flag; @@ -3945,7 +3991,7 @@ compare_field_class(cblc_field_t *conditional, right_len); } - if( left_value <= value && value <= right_value ) + if( left_value <= fp128 && fp128 <= right_value ) { retval = 0; break; @@ -4025,12 +4071,12 @@ local_is_alpha(int type, bool address_of) static int -compare_strings(char *left_string, - size_t left_length, - bool left_all, - char *right_string, - size_t right_length, - bool right_all) +compare_strings(const char *left_string, + size_t left_length, + bool left_all, + const char *right_string, + size_t right_length, + bool right_all) { int retval = 0; size_t i = 0; @@ -4284,6 +4330,7 @@ __gg__compare_2(cblc_field_t *left_side, retval = 0; retval = value < 0 ? -1 : retval; retval = value > 0 ? 1 : retval; + compare = true; break; } @@ -4294,6 +4341,7 @@ __gg__compare_2(cblc_field_t *left_side, retval = 0; retval = value < 0 ? -1 : retval; retval = value > 0 ? 1 : retval; + compare = true; break; } @@ -4312,9 +4360,7 @@ __gg__compare_2(cblc_field_t *left_side, compare = true; break; } - compare = true; goto fixup_retval; - break; } } } @@ -4329,10 +4375,10 @@ __gg__compare_2(cblc_field_t *left_side, if( local_is_alpha(left_side->type, left_address_of) && local_is_alpha(right_side->type, right_address_of) ) { - retval = compare_strings( (char *)left_location, + retval = compare_strings( reinterpret_cast<char *>(left_location), left_length, left_all, - (char *)right_location, + reinterpret_cast<char *>(right_location), right_length, right_all ); @@ -4368,12 +4414,13 @@ __gg__compare_2(cblc_field_t *left_side, // literal to be the same flavor as the left side: // We need to replace any commas with periods static size_t size = 128; - static char *buffer = (char *)malloc(size); + static char *buffer = static_cast<char *>(malloc(size)); while( strlen(right_side->initial)+1 > size ) { size *= 2; - buffer = (char *)malloc(size); + buffer = static_cast<char *>(malloc(size)); } + massert(buffer); strcpy(buffer, right_side->initial); if( __gg__decimal_point == ',' ) { @@ -4391,31 +4438,31 @@ __gg__compare_2(cblc_field_t *left_side, { case 4: { - _Float32 left_value = *(_Float32 *)left_location; - _Float32 right_value = strtof(buffer, NULL); + _Float32 left_value4 = *PTRCAST(_Float32, left_location); + _Float32 right_value4 = strtof(buffer, NULL); retval = 0; - retval = left_value < right_value ? -1 : retval; - retval = left_value > right_value ? 1 : retval; + retval = left_value4 < right_value4 ? -1 : retval; + retval = left_value4 > right_value4 ? 1 : retval; break; } case 8: { - _Float64 left_value = *(_Float64 *)left_location; - _Float64 right_value = strtod(buffer, NULL); + _Float64 left_value8 = *PTRCAST(_Float64, left_location); + _Float64 right_value8 = strtod(buffer, NULL); retval = 0; - retval = left_value < right_value ? -1 : retval; - retval = left_value > right_value ? 1 : retval; + retval = left_value8 < right_value8 ? -1 : retval; + retval = left_value8 > right_value8 ? 1 : retval; break; } case 16: { //_Float128 left_value = *(_Float128 *)left_location; - GCOB_FP128 left_value; - memcpy(&left_value, left_location, 16); - GCOB_FP128 right_value = strtofp128(buffer, NULL); + GCOB_FP128 left_value16; + memcpy(&left_value16, left_location, 16); + GCOB_FP128 right_value16 = strtofp128(buffer, NULL); retval = 0; - retval = left_value < right_value ? -1 : retval; - retval = left_value > right_value ? 1 : retval; + retval = left_value16 < right_value16 ? -1 : retval; + retval = left_value16 > right_value16 ? 1 : retval; break; } } @@ -4500,10 +4547,10 @@ __gg__compare_2(cblc_field_t *left_side, if( right_refmod ) { - retval = compare_strings( (char *)left_location, + retval = compare_strings( reinterpret_cast<char *>(left_location), left_length, left_all, - (char *)right_location, + reinterpret_cast<char *>(right_location), right_length, right_all); compare = true; @@ -4521,12 +4568,13 @@ __gg__compare_2(cblc_field_t *left_side, // VAL5 EQUAL "005" is TRUE if( left_side->type == FldLiteralA ) { - left_location = (unsigned char *)left_side->data; + left_location = reinterpret_cast<unsigned char *>(left_side->data); left_length = left_side->capacity; } static size_t right_string_size = MINIMUM_ALLOCATION_SIZE; - static char *right_string = (char *)malloc(right_string_size); + static char *right_string + = static_cast<char *>(malloc(right_string_size)); right_string = format_for_display_internal( &right_string, @@ -4550,7 +4598,7 @@ __gg__compare_2(cblc_field_t *left_side, left_length -= 1; } - char *right_fixed; + const char *right_fixed; if( *right_string == internal_plus || *right_string == internal_minus ) { right_fixed = right_string + 1; @@ -4560,7 +4608,7 @@ __gg__compare_2(cblc_field_t *left_side, right_fixed = right_string; } - retval = compare_strings( (char *)left_location, + retval = compare_strings( reinterpret_cast<char *>(left_location), left_length, left_all, right_fixed, @@ -4793,16 +4841,16 @@ sort_contents(unsigned char *contents, extern "C" void -__gg__sort_table( cblc_field_t *table, - size_t table_o, - size_t depending_on, - size_t nkeys, - cblc_field_t **keys, - size_t *ascending, - int duplicates ) +__gg__sort_table( const cblc_field_t *table, + size_t table_o, + size_t depending_on, + size_t nkeys, + cblc_field_t **keys, + size_t *ascending, + int duplicates ) { size_t buffer_size = 128; - unsigned char *contents = (unsigned char *)malloc(buffer_size); + unsigned char *contents = static_cast<unsigned char *>(malloc(buffer_size)); size_t offset = 0; std::vector<size_t>offsets; size_t record_size = table->capacity; @@ -4814,7 +4862,7 @@ __gg__sort_table( cblc_field_t *table, while( offset + sizeof(size_t) + record_size > buffer_size ) { buffer_size *= 2; - contents = (unsigned char *)realloc(contents, buffer_size); + contents = static_cast<unsigned char *>(realloc(contents, buffer_size)); } offsets.push_back(offset); memcpy(contents+offset, &record_size, sizeof(size_t)); @@ -4894,7 +4942,7 @@ init_var_both(cblc_field_t *var, { //fprintf(stderr, "ABORTING on %2.2d %s %d\n", var->level, var->name, var->type); //abort(); - var->data = (unsigned char *)malloc(var->capacity); + var->data = static_cast<unsigned char *>(malloc(var->capacity)); } // Set the "initialized" bit, which is tested in parser_symbol_add to make @@ -4920,11 +4968,11 @@ init_var_both(cblc_field_t *var, // We need to convert the options to the internal native codeset size_t buffer_size = 4; - char *buffer = (char *)malloc(buffer_size); + char *buffer = static_cast<char *>(malloc(buffer_size)); size_t index = 0; - cblc_field_t *parent = var->parent; + const cblc_field_t *parent = var->parent; switch(parent->type) { case FldGroup: @@ -4934,9 +4982,9 @@ init_var_both(cblc_field_t *var, while(*walker) { static size_t first_size = MINIMUM_ALLOCATION_SIZE; - static char *first = (char *)malloc(first_size); + static char *first = static_cast<char *>(malloc(first_size)); static size_t last_size = MINIMUM_ALLOCATION_SIZE; - static char *last = (char *)malloc(last_size); + static char *last = static_cast<char *>(malloc(last_size)); if( (*walker & 0xFF) == 0xFF ) { strcpy(first, walker); @@ -4959,7 +5007,7 @@ init_var_both(cblc_field_t *var, while(index + strlen(first) + strlen(last) + 3 > buffer_size) { buffer_size *= 2; - buffer = (char *)realloc(buffer, buffer_size); + buffer = static_cast<char *>(realloc(buffer, buffer_size)); } strcpy(buffer+index, first); index += strlen(first) + 1; @@ -4972,7 +5020,7 @@ init_var_both(cblc_field_t *var, } if( index > 0 ) { - buffer = (char *)realloc(buffer, index); + buffer = static_cast<char *>(realloc(buffer, index)); local_initial = buffer; } } @@ -5012,7 +5060,7 @@ init_var_both(cblc_field_t *var, // memory to the default. But if a parent has been initialized, we must not // touch our memory: bool a_parent_initialized = false; - if( var->data && !explicitly ) + if( !explicitly ) { while(parent) { @@ -5228,7 +5276,7 @@ init_var_both(cblc_field_t *var, __gg__abort("Unknown variable type"); } - char *location = (char *)save_the_location; + char *location = reinterpret_cast<char *>(save_the_location); there_is_more = false; size_t i=0; @@ -5254,7 +5302,7 @@ init_var_both(cblc_field_t *var, } } - outer_location = (unsigned char *)location; + outer_location = reinterpret_cast<unsigned char *>(location); } while(there_is_more); var->data = save_the_location; @@ -5301,7 +5349,7 @@ alpha_to_alpha_move_from_location(cblc_field_t *field, // and dest are alphanumeric dest_length = dest_length ? dest_length : field->capacity; - char *to = (char *)field->data + dest_offset; + char *to = reinterpret_cast<char *>(field->data + dest_offset); const char *from = source_location; size_t count = std::min(dest_length, source_length); @@ -5397,7 +5445,7 @@ static void alpha_to_alpha_move(cblc_field_t *dest, size_t dest_offset, size_t dest_size, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size, bool source_move_all) @@ -5405,7 +5453,7 @@ alpha_to_alpha_move(cblc_field_t *dest, alpha_to_alpha_move_from_location( dest, dest_offset, dest_size, - (char *)(source->data + source_offset), + reinterpret_cast<char *>(source->data + source_offset), source_size, source_move_all); } @@ -5439,13 +5487,9 @@ __gg__move( cblc_field_t *fdest, { int size_error = 0; // This is the return value - bool moved = true; - __int128 value; int rdigits; - size_t min_length; - cbl_figconst_t source_figconst = (cbl_figconst_t)(fsource->attr & FIGCONST_MASK); cbl_field_type_t dest_type = (cbl_field_type_t)fdest->type; @@ -5489,7 +5533,7 @@ __gg__move( cblc_field_t *fdest, * standard COBOL and its use should be avoided */ - int special_char; + int special_char = 0; // quiets cppcheck if( source_figconst == low_value_e ) { special_char = ascii_to_internal(__gg__low_value_character); @@ -5512,6 +5556,8 @@ __gg__move( cblc_field_t *fdest, } else { + size_t min_length; + bool moved = true; switch( dest_type ) { case FldGroup: @@ -5592,9 +5638,6 @@ __gg__move( cblc_field_t *fdest, // alphanumeric. We ignore any sign bit, and just // move the characters: - int rdigits; - __int128 value; - size_t source_digits = fsource->digits + ( fsource->rdigits < 0 @@ -5760,7 +5803,7 @@ __gg__move( cblc_field_t *fdest, fsource, source_offset, source_size); - sprintf(ach, "%lu", (size_t)value); + sprintf(ach, "%lu", (unsigned long)value); char *pach = ach; @@ -5884,31 +5927,31 @@ __gg__move( cblc_field_t *fdest, { rdigits = get_scaled_rdigits(fdest); bool negative = false; - __int128 value=0; + __int128 value128 = 0; switch(fsource->capacity) { case 4: { - _Float32 val = *(_Float32 *)(fsource->data+source_offset); + _Float32 val = *PTRCAST(_Float32, fsource->data+source_offset); if(val < 0) { negative = true; val = -val; } - val *= (_Float32)__gg__power_of_ten(rdigits); - value = (__int128)val; + val *= static_cast<_Float32>(__gg__power_of_ten(rdigits)); + value128 = (__int128)val; break; } case 8: { - _Float64 val = *(_Float64 *)(fsource->data+source_offset); + _Float64 val = *PTRCAST(_Float64, fsource->data+source_offset); if(val < 0) { negative = true; val = -val; } val *= (_Float32)__gg__power_of_ten(rdigits); - value = (__int128)val; + value128 = (__int128)val; break; } case 16: @@ -5922,19 +5965,19 @@ __gg__move( cblc_field_t *fdest, val = -val; } val *= (_Float32)__gg__power_of_ten(rdigits); - value = (__int128)val; + value128 = (__int128)val; break; } } if( negative ) { - value = -value; + value128 = -value128; } __gg__int128_to_qualified_field( fdest, dest_offset, dest_size, - value, + value128, rdigits, rounded, &size_error ); @@ -6002,30 +6045,30 @@ __gg__move( cblc_field_t *fdest, // We are converted a floating-point value fixed-point rdigits = get_scaled_rdigits(fdest); - GCOB_FP128 value=0; + GCOB_FP128 fp128=0; switch(fsource->capacity) { case 4: { - value = *(_Float32 *)(fsource->data+source_offset); + fp128 = *reinterpret_cast<_Float32 *>(fsource->data+source_offset); break; } case 8: { - value = *(_Float64 *)(fsource->data+source_offset); + fp128 = *reinterpret_cast<_Float64 *>(fsource->data+source_offset); break; } case 16: { // value = *(_Float128 *)(fsource->data+source_offset); - memcpy(&value, fsource->data+source_offset, 16); + memcpy(&fp128, fsource->data+source_offset, 16); break; } } __gg__float128_to_qualified_field( fdest, dest_offset, - value, + fp128, rounded, &size_error); break; @@ -6056,9 +6099,6 @@ __gg__move( cblc_field_t *fdest, case FldNumericDisplay: { - int rdigits; - __int128 value; - int source_digits = fsource->digits + (fsource->rdigits<0 ? -fsource->rdigits : 0) ; // Pick up the absolute value of the source @@ -6079,7 +6119,7 @@ __gg__move( cblc_field_t *fdest, } // And move them into place: - __gg__string_to_alpha_edited( (char *)(fdest->data+dest_offset), + __gg__string_to_alpha_edited( reinterpret_cast<char *>(fdest->data+dest_offset), ach, source_digits, fdest->picture); @@ -6089,7 +6129,7 @@ __gg__move( cblc_field_t *fdest, default: { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = (char *)malloc(display_string_size); + static char *display_string = static_cast<char *>(malloc(display_string_size)); size_t display_string_length = dest_size; __gg__realloc_if_necessary( &display_string, @@ -6122,12 +6162,12 @@ __gg__move( cblc_field_t *fdest, &display_string, &display_string_size, fsource, - (unsigned char *)(fsource->data+source_offset), + reinterpret_cast<unsigned char *>(fsource->data+source_offset), source_size, source_flags && REFER_T_ADDRESS_OF); display_string_length = strlen(display_string); } - __gg__string_to_alpha_edited( (char *)(fdest->data+dest_offset), + __gg__string_to_alpha_edited( reinterpret_cast<char *>(fdest->data+dest_offset), display_string, display_string_length, fdest->picture); @@ -6152,12 +6192,12 @@ __gg__move( cblc_field_t *fdest, { case 4: { - *(float *)(fdest->data+dest_offset) = strtof(ach, NULL); + *PTRCAST(float, fdest->data+dest_offset) = strtod(ach, NULL); break; } case 8: { - *(double *)(fdest->data+dest_offset) = strtod(ach, NULL); + *PTRCAST(double, fdest->data+dest_offset) = strtod(ach, NULL); break; } case 16: @@ -6167,7 +6207,6 @@ __gg__move( cblc_field_t *fdest, memcpy(fdest->data+dest_offset, &t, 16); break; } - break; } break; } @@ -6296,7 +6335,7 @@ __gg__move_literala(cblc_field_t *field, case FldAlphaEdited: { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = (char *)malloc(display_string_size); + static char *display_string = static_cast<char *>(malloc(display_string_size)); __gg__realloc_if_necessary( &display_string, &display_string_size, @@ -6305,7 +6344,7 @@ __gg__move_literala(cblc_field_t *field, memset(display_string, internal_space, display_string_size); size_t len = std::min(display_string_size, strlen); memcpy(display_string, str, len); - __gg__string_to_alpha_edited( (char *)(field->data+field_offset), + __gg__string_to_alpha_edited( reinterpret_cast<char *>(field->data+field_offset), display_string, field_size, field->picture); @@ -6322,12 +6361,12 @@ __gg__move_literala(cblc_field_t *field, { case 4: { - *(float *)(field->data+field_offset) = strtof(ach, NULL); + *PTRCAST(float, field->data+field_offset) = strtod(ach, NULL); break; } case 8: { - *(double *)(field->data+field_offset) = strtod(ach, NULL); + *PTRCAST(double, field->data+field_offset) = strtod(ach, NULL); break; } case 16: @@ -6336,7 +6375,6 @@ __gg__move_literala(cblc_field_t *field, memcpy(field->data+field_offset, &t, 16); break; } - break; } break; } @@ -6457,7 +6495,7 @@ __gg__sort_workfile(cblc_file_t *workfile, // Read the file into memory size_t buffer_size = 128; - unsigned char *contents = (unsigned char *)malloc(buffer_size); + unsigned char *contents = static_cast<unsigned char *>(malloc(buffer_size)); size_t offset = 0; std::vector<size_t>offsets; size_t bytes_read; @@ -6487,7 +6525,7 @@ __gg__sort_workfile(cblc_file_t *workfile, while( offset + sizeof(size_t) + bytes_read > buffer_size ) { buffer_size *= 2; - contents = (unsigned char *)realloc(contents, buffer_size); + contents = static_cast<unsigned char *>(realloc(contents, buffer_size)); } offsets.push_back(offset); @@ -6586,7 +6624,8 @@ __gg__merge_files( cblc_file_t *workfile, return; } - unsigned char *prior_winner = (unsigned char *)malloc(the_biggest); + unsigned char *prior_winner = static_cast<unsigned char *>(malloc(the_biggest)); + massert(prior_winner); *prior_winner = '\0'; for(;;) @@ -6766,7 +6805,7 @@ normalize_id( const cblc_field_t *refer, if( refer ) { - unsigned char *data = refer->data + refer_o; + const unsigned char *data = refer->data + refer_o; cbl_figconst_t figconst = (cbl_figconst_t)(refer->attr & FIGCONST_MASK); @@ -7007,7 +7046,7 @@ the_alpha_and_omega_backward( const normalized_operand &id_before, static void -inspect_backward_format_1(size_t integers[]) +inspect_backward_format_1(const size_t integers[]) { size_t int_index = 0; size_t cblc_index = 0; @@ -7020,9 +7059,9 @@ inspect_backward_format_1(size_t integers[]) std::vector<id_2_result> id_2_results(n_identifier_2); // Pick up identifier_1, which is the string being inspected - cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; + size_t id1_o = __gg__treeplet_1o[cblc_index]; + size_t id1_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; // normalize it, according to the language specification. normalized_operand normalized_id_1 = normalize_id(id1, id1_o, id1_s); @@ -7055,19 +7094,19 @@ inspect_backward_format_1(size_t integers[]) // We are counting characters. There is no identifier-3, // but we we hard-code the length to one to represent a // single character. - comparand next_comparand; + comparand next_comparand = {}; next_comparand.id_2_index = i; next_comparand.operation = operation; next_comparand.identifier_3.length = 1; - cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; normalized_operand normalized_id_4_before @@ -7099,23 +7138,23 @@ inspect_backward_format_1(size_t integers[]) for(size_t k=0; k<pair_count; k++) { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.id_2_index = i; next_comparand.operation = operation; - cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; + size_t id3_o = __gg__treeplet_1o[cblc_index]; + size_t id3_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_3 @@ -7356,9 +7395,9 @@ __gg__inspect_format_1(int backward, size_t integers[]) std::vector<id_2_result> id_2_results(n_identifier_2); // Pick up identifier_1, which is the string being inspected - cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; + size_t id1_o = __gg__treeplet_1o[cblc_index]; + size_t id1_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; // normalize it, according to the language specification. normalized_operand normalized_id_1 @@ -7392,19 +7431,19 @@ __gg__inspect_format_1(int backward, size_t integers[]) // We are counting characters. There is no identifier-3, // but we we hard-code the length to one to represent a // single character. - comparand next_comparand; + comparand next_comparand = {}; next_comparand.id_2_index = i; next_comparand.operation = operation; next_comparand.identifier_3.length = 1; - cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; normalized_operand normalized_id_4_before @@ -7436,23 +7475,23 @@ __gg__inspect_format_1(int backward, size_t integers[]) for(size_t k=0; k<pair_count; k++) { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.id_2_index = i; next_comparand.operation = operation; - cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; + size_t id3_o = __gg__treeplet_1o[cblc_index]; + size_t id3_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_3 @@ -7681,7 +7720,7 @@ __gg__inspect_format_1(int backward, size_t integers[]) static void -inspect_backward_format_2(size_t integers[]) +inspect_backward_format_2(const size_t integers[]) { size_t int_index = 0; size_t cblc_index = 0; @@ -7711,22 +7750,22 @@ inspect_backward_format_2(size_t integers[]) { case bound_characters_e: { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.operation = operation; - cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; + size_t id5_o = __gg__treeplet_1o[cblc_index]; + size_t id5_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_5 @@ -7762,27 +7801,27 @@ inspect_backward_format_2(size_t integers[]) for(size_t k=0; k<pair_count; k++) { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.operation = operation; - cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; + size_t id3_o = __gg__treeplet_1o[cblc_index]; + size_t id3_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; + size_t id5_o = __gg__treeplet_1o[cblc_index]; + size_t id5_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_3 = normalize_id(id3, id3_o, id3_s); @@ -8059,22 +8098,22 @@ __gg__inspect_format_2(int backward, size_t integers[]) { case bound_characters_e: { - comparand next_comparand; + comparand next_comparand = {} ; next_comparand.operation = operation; - cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; + size_t id5_o = __gg__treeplet_1o[cblc_index]; + size_t id5_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_5 @@ -8110,27 +8149,27 @@ __gg__inspect_format_2(int backward, size_t integers[]) for(size_t k=0; k<pair_count; k++) { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.operation = operation; - cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; + size_t id3_o = __gg__treeplet_1o[cblc_index]; + size_t id3_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; + size_t id5_o = __gg__treeplet_1o[cblc_index]; + size_t id5_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_3 = normalize_id(id3, id3_o, id3_s); @@ -8405,12 +8444,12 @@ __gg__inspect_format_4( int backward, static size_t psz_before_size = MINIMUM_ALLOCATION_SIZE; static size_t psz_figstring_size = MINIMUM_ALLOCATION_SIZE; - static char *psz_input = (char *)malloc(psz_input_size ); - static char *psz_original = (char *)malloc(psz_original_size ); - static char *psz_replacement = (char *)malloc(psz_replacement_size); - static char *psz_after = (char *)malloc(psz_after_size ); - static char *psz_before = (char *)malloc(psz_before_size ); - static char *psz_figstring = (char *)malloc(psz_figstring_size ); + static char *psz_input = static_cast<char *>(malloc(psz_input_size )); + static char *psz_original = static_cast<char *>(malloc(psz_original_size )); + static char *psz_replacement = static_cast<char *>(malloc(psz_replacement_size)); + static char *psz_after = static_cast<char *>(malloc(psz_after_size )); + static char *psz_before = static_cast<char *>(malloc(psz_before_size )); + static char *psz_figstring = static_cast<char *>(malloc(psz_figstring_size )); bool all = replacement_size == (size_t)(-1LL); if( all ) @@ -8504,7 +8543,7 @@ __gg__inspect_format_4( int backward, } char *pstart = NULL; - char *pend = NULL; + const char *pend = NULL; if( backward ) { if( strlen(psz_before) ) @@ -8597,7 +8636,7 @@ move_string(cblc_field_t *field, case FldAlphanumeric: case FldAlphaEdited: { - char *to = (char *)(field->data + offset); + char *to = reinterpret_cast<char *>(field->data + offset); size_t dest_length = length ? length : field->capacity; size_t source_length = strlen_from; size_t count = std::min(dest_length, source_length); @@ -8706,7 +8745,7 @@ brute_force_trim(char *str) extern "C" int -__gg__string(size_t integers[]) +__gg__string(const size_t integers[]) { // The first integer is the count of identifier-2 values. Call it N // The following N integers are the counts of each of the identifier-1 values, @@ -8720,12 +8759,11 @@ __gg__string(size_t integers[]) // And so on cblc_field_t **ref = __gg__treeplet_1f; - size_t *ref_o = __gg__treeplet_1o; - size_t *ref_s = __gg__treeplet_1s; + const size_t *ref_o = __gg__treeplet_1o; + const size_t *ref_s = __gg__treeplet_1s; static const int INDEX_OF_POINTER = 1; - size_t index_int = 0; size_t index_cblc = 0 ; char figlow[2] = {ascii_to_internal(__gg__low_value_character), 0x00}; @@ -8743,15 +8781,13 @@ __gg__string(size_t integers[]) fighigh[0] = ascii_to_internal(__gg__high_value_character); } - // Pick up the number of identifier-2 values - size_t N = integers[index_int++]; // Pick up the target - cblc_field_t *tgt = ref[index_cblc]; - size_t tgt_o = ref_o[index_cblc]; - size_t tgt_s = ref_s[index_cblc]; + const cblc_field_t *tgt = ref[index_cblc]; + size_t tgt_o = ref_o[index_cblc]; + size_t tgt_s = ref_s[index_cblc]; index_cblc += 1; - char *dest = (char *)(tgt->data + tgt_o); + char *dest = reinterpret_cast<char *>(tgt->data + tgt_o); ssize_t dest_length = tgt_s; // Skip over the index of POINTER: @@ -8778,18 +8814,23 @@ __gg__string(size_t integers[]) { // We are go for looping through identifier-2 values: + size_t index_int = 0; + + // Pick up the number of identifier-2 values + size_t N = integers[index_int++]; + for( size_t i=0; i<N; i++ ) { size_t M = integers[index_int++]; // Pick up the identifier_2 DELIMITED BY value - cblc_field_t *id2 = ref[index_cblc]; - size_t id2_o = ref_o[index_cblc]; - size_t id2_s = ref_s[index_cblc]; + const cblc_field_t *id2 = ref[index_cblc]; + size_t id2_o = ref_o[index_cblc]; + size_t id2_s = ref_s[index_cblc]; index_cblc += 1; char *piece; - char *piece_end; + const char *piece_end; cbl_figconst_t figconst = (cbl_figconst_t) ( id2 ? (id2->attr & FIGCONST_MASK) : 0 ); @@ -8816,24 +8857,24 @@ __gg__string(size_t integers[]) piece_end = piece + 1; break; default: - piece = id2 ? (char *)(id2->data + id2_o) : NULL; + piece = id2 ? reinterpret_cast<char *>(id2->data + id2_o) : NULL; piece_end = id2 ? piece + id2_s : NULL; break; } - for(size_t i=0; i<M; i++) + for(size_t j=0; j<M; j++) { // Pick up the next identifier-1 source string: - cblc_field_t *id1 = ref[index_cblc]; + const cblc_field_t *id1 = ref[index_cblc]; size_t id1_o = ref_o[index_cblc]; size_t id1_s = ref_s[index_cblc]; index_cblc += 1; - const char *whole = id1 ? (const char *)(id1->data + id1_o): NULL ; + const char *whole = id1 ? reinterpret_cast<char *>(id1->data + id1_o): NULL ; const char *whole_end = id1 ? whole + id1_s : NULL; // As usual, we need to cope with figurative constants: - cbl_figconst_t figconst = (cbl_figconst_t) ( id1 ? (id1->attr & FIGCONST_MASK) : 0 ); + figconst = (cbl_figconst_t) ( id1 ? (id1->attr & FIGCONST_MASK) : 0 ); switch( figconst ) { case low_value_e: @@ -8866,11 +8907,7 @@ __gg__string(size_t integers[]) whole, whole_end); if(found) { -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wcast-qual" - char *wfound = (char *)found; -#pragma GCC diagnostic pop - whole_end = wfound; + whole_end = found; } } while(whole < whole_end) @@ -8920,7 +8957,7 @@ display_both(cblc_field_t *field, int advance ) { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = (char *)malloc(display_string_size); + static char *display_string = static_cast<char *>(malloc(display_string_size)); format_for_display_internal(&display_string, &display_string_size, @@ -8931,7 +8968,7 @@ display_both(cblc_field_t *field, // Let's honor the locale of the system, as best we can: static size_t converted_size = MINIMUM_ALLOCATION_SIZE; - static char *converted = (char *)malloc(converted_size); + static char *converted = static_cast<char *>(malloc(converted_size)); internal_to_console(&converted, &converted_size, display_string, strlen(display_string)); @@ -8941,7 +8978,7 @@ display_both(cblc_field_t *field, if(ss == -1) { fprintf(stderr, "__gg__display() %s %p\n", field->name, qual_data); - fprintf(stderr, "__gg__display() %zd\n", converted_size); + fprintf(stderr, "__gg__display() %ld\n", static_cast<long>(converted_size)); fprintf(stderr, "__gg__display() "); for(size_t i=0; i<converted_size; i++) { @@ -8953,9 +8990,9 @@ display_both(cblc_field_t *field, if( advance ) { - ss = write( file_descriptor, - "\n", - 1); + write( file_descriptor, + "\n", + 1); } } @@ -8994,20 +9031,20 @@ __gg__display_clean(cblc_field_t *field, extern "C" void -__gg__display_string( int file_descriptor, - char *str, - size_t length, - int advance ) +__gg__display_string( int file_descriptor, + const char *str, + size_t length, + int advance ) { // Let's honor the locale of the system, as best we can: static size_t converted_size = MINIMUM_ALLOCATION_SIZE; - static char *converted = (char *)malloc(converted_size); + static char *converted = static_cast<char *>(malloc(converted_size)); size_t max_possible = 2 * length; if( max_possible > converted_size ) { converted_size = max_possible; - converted = (char *)realloc(converted, converted_size); + converted = static_cast<char *>(realloc(converted, converted_size)); } __gg__ascii_to_console(&converted, &converted_size, str, length); @@ -9143,7 +9180,8 @@ __gg__accept( enum special_name_t special_e, } } - char *buffer = (char *)malloc(max_chars+1); + char *buffer = static_cast<char *>(malloc(max_chars+1)); + massert(buffer); memset(buffer, ascii_space, max_chars); buffer[max_chars] = NULLCH; size_t i = 0; @@ -9309,7 +9347,7 @@ __gg__binary_value_from_field( int *rdigits, extern "C" __int128 __gg__binary_value_from_qualified_field(int *rdigits, - cblc_field_t *var, + const cblc_field_t *var, size_t offset, size_t size) { @@ -9342,7 +9380,7 @@ __gg__float128_from_field( cblc_field_t *field ) extern "C" GCOB_FP128 -__gg__float128_from_qualified_field( cblc_field_t *field, size_t offset, size_t size) +__gg__float128_from_qualified_field(const cblc_field_t *field, size_t offset, size_t size) { GCOB_FP128 retval=0; if( field->type == FldFloat || field->type == FldLiteralN ) @@ -9419,11 +9457,11 @@ __gg__int128_to_qualified_field(cblc_field_t *tgt, } static __int128 -float128_to_int128( int *rdigits, - cblc_field_t *field, - GCOB_FP128 value, - cbl_round_t rounded, - int *compute_error) +float128_to_int128( int *rdigits, + const cblc_field_t *field, + GCOB_FP128 value, + cbl_round_t rounded, + int *compute_error) { __int128 retval = 0; if( value == INFINITY ) @@ -9505,16 +9543,16 @@ float128_to_location( cblc_field_t *tgt, } if( value < 0 ) { - *(float *)(data) = -INFINITY; + *PTRCAST(float, data) = -INFINITY; } else { - *(float *)(data) = INFINITY; + *PTRCAST(float, data) = INFINITY; } } else { - *(float *)(data) = (float)value; + *PTRCAST(float, data) = static_cast<float>(value); } break; @@ -9528,16 +9566,16 @@ float128_to_location( cblc_field_t *tgt, } if( value < 0 ) { - *(double *)(data) = -INFINITY; + *PTRCAST(double, data) = -INFINITY; } else { - *(double *)(data) = INFINITY; + *PTRCAST(double, data) = INFINITY; } } else { - *(double *)(data) = (double)value; + *PTRCAST(double, data) = static_cast<double>(value); } break; @@ -9738,7 +9776,7 @@ __gg__set_initial_switch_value( ) __int128 bit = 1; char ach[129]; memset(ach, 0, sizeof(ach)); - char *p = getenv("UPSI"); + const char *p = getenv("UPSI"); if( p ) { snprintf(ach, sizeof(ach), "%s", p); @@ -9771,7 +9809,7 @@ is_numeric_display_numeric(cblc_field_t *field, size_t offset, size_t size) bool leading = !!(field->attr & leading_e); bool separate = !!(field->attr & separate_e); - char *digits = (char *)(field->data + offset); + char *digits = reinterpret_cast<char *>(field->data + offset); char *digits_e = digits + size; if( leading && separate && signable ) @@ -9843,13 +9881,13 @@ is_numeric_display_numeric(cblc_field_t *field, size_t offset, size_t size) } static int -is_packed_numeric(cblc_field_t *field, size_t offset, size_t size) +is_packed_numeric(const cblc_field_t *field, size_t offset, size_t size) { int retval = 1; bool is_comp6 = !!(field->attr&packed_no_sign_e); int digits = field->digits; bool signable = !!(field->attr & signable_e); - unsigned char *bytes = field->data + offset; + const unsigned char *bytes = field->data + offset; int nybble = 0; int nybble_e = nybble + digits; @@ -9918,10 +9956,12 @@ is_packed_numeric(cblc_field_t *field, size_t offset, size_t size) } static int -is_alpha_a_number(cblc_field_t *field, size_t offset, size_t size) +is_alpha_a_number(const cblc_field_t *field, + size_t offset, + size_t size) { int retval = 1; - unsigned char *bytes = (field->data + offset); + const unsigned char *bytes = (field->data + offset); for( size_t i=0; i<size; i++ ) { unsigned char ch = bytes[i]; @@ -9945,7 +9985,7 @@ __gg__classify( classify_t type, // The default answer is TRUE int retval = 1; - const unsigned char *alpha = (unsigned char *)(field->data+offset); + const unsigned char *alpha = reinterpret_cast<unsigned char *>(field->data+offset); size_t str_length = size; @@ -10095,7 +10135,7 @@ __gg__accept_envar( cblc_field_t *tgt, if( env_length < name_length+1 ) { env_length = name_length+1; - env = (char *)realloc(env, env_length); + env = static_cast<char *>(realloc(env, env_length)); } memcpy(env, name->data + name_offset, name_length); env[name_length] = '\0'; @@ -10107,7 +10147,7 @@ __gg__accept_envar( cblc_field_t *tgt, __gg__internal_to_console_in_place(trimmed_env, strlen(trimmed_env)); // Pick up the environment variable, and convert it to the internal codeset - char *p = getenv(trimmed_env); + const char *p = getenv(trimmed_env); if(p) { char *pp = strdup(p); @@ -10146,14 +10186,17 @@ __gg__set_envar(cblc_field_t *name, if( env_length < name_length+1 ) { env_length = name_length+1; - env = (char *)realloc(env, env_length); + env = static_cast<char *>(realloc(env, env_length)); } if( val_length < value_length+1 ) { val_length = value_length+1; - val = (char *)realloc(val, val_length); + val = static_cast<char *>(realloc(val, val_length)); } + massert(val); + massert(env); + // The name and the value arrive in the internal codeset: memcpy(env, name->data+name_offset , name_length); env[name_length] = '\0'; @@ -10222,15 +10265,15 @@ command_line_plan_b() if( bytes_read ) { char *p = input; - char *p_end = p + bytes_read; + const char *p_end = p + bytes_read; char prior_char = '\0'; while( p < p_end ) { if( prior_char == '\0' ) { stashed_argc += 1; - stashed_argv = (char **)realloc(stashed_argv, - stashed_argc * sizeof(char *)); + stashed_argv = static_cast<char **>(realloc(stashed_argv, + stashed_argc * sizeof(char *))); stashed_argv[stashed_argc-1] = p; } prior_char = *p++; @@ -10301,7 +10344,8 @@ __gg__get_command_line( cblc_field_t *field, int retcode; command_line_plan_b(); size_t length = 1; - char *retval = (char *)malloc(length); + char *retval = static_cast<char *>(malloc(length)); + massert(retval); *retval = NULLCH; for( int i=1; i<stashed_argc; i++ ) @@ -10309,7 +10353,8 @@ __gg__get_command_line( cblc_field_t *field, while( strlen(retval) + strlen(stashed_argv[i]) + 2 > length ) { length *= 2; - retval = (char *)realloc(retval, length); + retval = static_cast<char *>(realloc(retval, length)); + massert(retval); } if( *retval ) { @@ -10337,12 +10382,12 @@ __gg__get_command_line( cblc_field_t *field, extern "C" void -__gg__set_pointer(cblc_field_t *target, - size_t target_o, - int target_flags, - cblc_field_t *source, - size_t source_o, - int source_flags) +__gg__set_pointer(cblc_field_t *target, + size_t target_o, + int target_flags, + const cblc_field_t *source, + size_t source_o, + int source_flags) { void *source_address; if( source_flags & REFER_T_ADDRESS_OF ) @@ -10355,7 +10400,7 @@ __gg__set_pointer(cblc_field_t *target, // This is SET <something> TO POINTER if( source ) { - source_address = *(void **)(source->data + source_o); + source_address = *reinterpret_cast<void **>(source->data + source_o); } else { @@ -10368,7 +10413,7 @@ __gg__set_pointer(cblc_field_t *target, { // This is SET ADDRESS OF target TO .... // We know it has to be an unqualified LINKAGE level 01 or level 77 - target->data = (unsigned char *)source_address; + target->data = reinterpret_cast<unsigned char *>(source_address); // The caller will propogate data + offset to their children. } else @@ -10379,12 +10424,12 @@ __gg__set_pointer(cblc_field_t *target, // This is [almost certainly] INITIALIZE <pointer> when -fdefaultbyte // was specified. memset( target->data+target_o, - *(unsigned char *)source_address, + *reinterpret_cast<unsigned char *>(source_address), target->capacity); } else { - *(void **)(target->data+target_o) = source_address; + *reinterpret_cast<void **>(target->data+target_o) = source_address; } } } @@ -10467,7 +10512,7 @@ extern "C" void __gg__ascii_to_internal_field(cblc_field_t *var) { - ascii_to_internal_str((char *)var->data, var->capacity); + ascii_to_internal_str(reinterpret_cast<char *>(var->data), var->capacity); } extern "C" @@ -10519,7 +10564,7 @@ void __gg__internal_to_console_in_place(char *loc, size_t length) { static size_t dest_size = MINIMUM_ALLOCATION_SIZE; - static char *dest = (char *)malloc(dest_size); + static char *dest = static_cast<char *>(malloc(dest_size)); internal_to_console(&dest, &dest_size, loc, length); memcpy(loc, dest, length); @@ -10527,8 +10572,8 @@ __gg__internal_to_console_in_place(char *loc, size_t length) extern "C" int -__gg__routine_to_call(char *name, - int program_id) +__gg__routine_to_call(const char *name, + int program_id) { // The list of names is sorted, so at the very least this should be replaced // with a binary search: @@ -10544,10 +10589,10 @@ __gg__routine_to_call(char *name, char **names = *(it->second); int retval = -1; - int i=0; if( names ) { + int i=0; while(*names) { if( strstr(*names, name) ) @@ -10569,14 +10614,14 @@ __gg__routine_to_call(char *name, extern "C" __int128 -__gg__fetch_call_by_value_value(cblc_field_t *field, +__gg__fetch_call_by_value_value(const cblc_field_t *field, size_t field_o, size_t field_s) { int rdigits; - unsigned char *data = field->data + field_o; - size_t length = field_s; + unsigned char *data = field->data + field_o; + const size_t length = field_s; __int128 retval = 0; switch(field->type) @@ -10585,7 +10630,7 @@ __gg__fetch_call_by_value_value(cblc_field_t *field, case FldAlphanumeric: case FldAlphaEdited: case FldLiteralA: - retval = *(char *)data; + retval = *reinterpret_cast<char *>(data); break; case FldFloat: @@ -10593,11 +10638,11 @@ __gg__fetch_call_by_value_value(cblc_field_t *field, switch(length) { case 4: - *(float *)(&retval) = *(float *)data; + *PTRCAST(float, &retval) = *PTRCAST(float, data); break; case 8: - *(double *)(&retval) = *(double *)data; + *PTRCAST(double, &retval) = *PTRCAST(double, data); break; case 16: @@ -10654,11 +10699,11 @@ __gg__assign_value_from_stack(cblc_field_t *dest, __int128 parameter) switch(dest->capacity) { case 4: - *(float *)(dest->data) = *(float *)¶meter; + *PTRCAST(float, dest->data) = *PTRCAST(float, (¶meter)); break; case 8: - *(double *)(dest->data) = *(double *)¶meter; + *PTRCAST(double, dest->data) = *PTRCAST(double, (¶meter)); break; case 16: @@ -10692,28 +10737,31 @@ __gg__assign_value_from_stack(cblc_field_t *dest, __int128 parameter) extern "C" int -__gg__literaln_alpha_compare(char *left_side, - cblc_field_t *right, - size_t offset, - size_t length, - int flags) +__gg__literaln_alpha_compare(const char *left_side, + const cblc_field_t *right, + size_t offset, + size_t length, + int flags) { int retval; if( length == 0 ) { length = right->capacity; } - retval = compare_strings( (char *)left_side, + retval = compare_strings( left_side, strlen(left_side), false, - (char *)right->data + offset, + reinterpret_cast<char *>((right->data + offset)), length, !!(flags & REFER_T_MOVE_ALL) ); return retval; } static char * -string_in(char *str, char *str_e, char *frag, char *frag_e) +string_in( char *str, + const char *str_e, + const char *frag, + const char *frag_e) { // This simple routine could be improved. Instead of using memcmp, we could // use established, albeit complex, techniques of string searching: @@ -10743,11 +10791,11 @@ string_in(char *str, char *str_e, char *frag, char *frag_e) extern "C" int -__gg__unstring( cblc_field_t *id1, // The string being unstring - size_t id1_o, - size_t id1_s, +__gg__unstring( const cblc_field_t *id1, // The string being unstring + size_t id1_o, + size_t id1_s, size_t ndelimiteds, // The number of DELIMITED entries - char *all_flags, // The number of ALL flags, one per ndelimiteds + const char *all_flags, // The number of ALL flags, one per ndelimiteds size_t nreceivers, // The number of DELIMITER receivers cblc_field_t *id7, // The index of characters, both for starting updated at end size_t id7_o, @@ -10766,18 +10814,22 @@ __gg__unstring( cblc_field_t *id1, // The string being unstring // resolved. Each might have an identifier-5 delimiter, and each might have // an identifier-6 count. - cblc_field_t **id2 = __gg__treeplet_1f; // The delimiting strings; one per ndelimiteds - size_t *id2_o = __gg__treeplet_1o; - size_t *id2_s = __gg__treeplet_1s; - cblc_field_t **id4 = __gg__treeplet_2f; // The delimited string; one per nreceiver - size_t *id4_o = __gg__treeplet_2o; - size_t *id4_s = __gg__treeplet_2s; - cblc_field_t **id5 = __gg__treeplet_3f; // The delimiting string; one per receiver - size_t *id5_o = __gg__treeplet_3o; - size_t *id5_s = __gg__treeplet_3s; - cblc_field_t **id6 = __gg__treeplet_4f; // The count of characters examined; one per receiver - size_t *id6_o = __gg__treeplet_4o; - size_t *id6_s = __gg__treeplet_4s; + // The delimiting strings; one per ndelimiteds + cblc_field_t **id2 = __gg__treeplet_1f; + const size_t *id2_o = __gg__treeplet_1o; + const size_t *id2_s = __gg__treeplet_1s; + // The delimited string; one per nreceiver + cblc_field_t **id4 = __gg__treeplet_2f; + const size_t *id4_o = __gg__treeplet_2o; + const size_t *id4_s = __gg__treeplet_2s; + // The delimiting string; one per receiver + cblc_field_t **id5 = __gg__treeplet_3f; + const size_t *id5_o = __gg__treeplet_3o; + const size_t *id5_s = __gg__treeplet_3s; + // The count of characters examined; one per receiver + cblc_field_t **id6 = __gg__treeplet_4f; + const size_t *id6_o = __gg__treeplet_4o; + const size_t *id6_s = __gg__treeplet_4s; // Initialize the state variables int overflow = 0; @@ -10820,8 +10872,8 @@ __gg__unstring( cblc_field_t *id1, // The string being unstring goto done; } - left = (char *)(id1->data+id1_o) + pointer-1; - right = (char *)(id1->data+id1_o) + id1_s; + left = reinterpret_cast<char *>(id1->data+id1_o) + pointer-1; + right = reinterpret_cast<char *>(id1->data+id1_o) + id1_s; if( ndelimiteds == 0 ) { @@ -10919,8 +10971,9 @@ __gg__unstring( cblc_field_t *id1, // The string being unstring default: pfound = string_in( left, right, - (char *)(id2[i]->data+id2_o[i]), - (char *)(id2[i]->data+id2_o[i]) + id2_s[i]); + reinterpret_cast<char *>(id2[i]->data+id2_o[i]), + reinterpret_cast<char *>((id2[i]->data+id2_o[i]) + + id2_s[i])); break; } @@ -10997,7 +11050,7 @@ __gg__unstring( cblc_field_t *id1, // The string being unstring else { move_string(id5[nreceiver], id5_o[nreceiver], id5_s[nreceiver], - (char *)(id2[ifound]->data+id2_o[ifound]), + reinterpret_cast<char *>(id2[ifound]->data+id2_o[ifound]), id2_s[ifound]); } } @@ -11092,15 +11145,15 @@ static inline ec_type_t local_ec_type_of( file_status_t status ) { int status10 = (int)status / 10; - assert( 0 <= status10 ); // was enum, can't be negative. - if( 10 < status10 ) + assert( 0 <= status10 ); // was enum, can't be negative. + if( 10 < status10 ) { __gg__abort("local_ec_type_of(): status10 out of range"); } - + static const std::vector<ec_type_t> ec_by_status { /* 0 */ ec_none_e, // ec_io_warning_e if low byte is nonzero - /* 1 */ ec_io_at_end_e, + /* 1 */ ec_io_at_end_e, /* 2 */ ec_io_invalid_key_e, /* 3 */ ec_io_permanent_error_e, /* 4 */ ec_io_logic_error_e, @@ -11122,11 +11175,12 @@ local_ec_type_of( file_status_t status ) */ struct exception_descr_t { bool location; - std::set<size_t> files; + //std::set<size_t> files; }; struct cbl_exception_t { - size_t program, file; +// size_t program, + size_t file; ec_type_t type; cbl_file_mode_t mode; }; @@ -11188,16 +11242,16 @@ default_exception_handler( ec_type_t ec ) { #if HAVE_DECL_PROGRAM_INVOCATION_SHORT_NAME /* Declared in errno.h, when available. */ - const char *ident = program_invocation_short_name; + static const char * const ident = program_invocation_short_name; #elif defined (HAVE_GETPROGNAME) /* Declared in stdlib.h. */ - const char *ident = getprogname(); + static const char * const ident = getprogname(); #else /* Avoid a NULL entry. */ - const char *ident = "unnamed_COBOL_program"; + static const char * const ident = "unnamed_COBOL_program"; #endif static bool first_time = true; - static int priority = LOG_INFO, option = LOG_PERROR, facility = LOG_USER; + static const int priority = LOG_INFO, option = LOG_PERROR, facility = LOG_USER; ec_disposition_t disposition = ec_category_fatal_e; if( first_time ) { @@ -11450,7 +11504,7 @@ cbl_enabled_exception_t::dump( int i ) const { * specific EC. It's matched based on the file's status, irrespective of * whether or not EC-I-O is enabled. USE Format 1 Declaratives are honored * regardless of any >>TURN directive. - * + * * An EC is enabled by the >>TURN directive. The only ECs that can be disabled * are those that were explicitly enabled. If EC-I-O is enabled, and mentioned * in a Declarative with USE Format 3, then it is matched just like any other. @@ -11465,19 +11519,19 @@ __gg__match_exception( cblc_field_t *index ) auto ec = ec_status.update().unhandled(); - if( ec != ec_none_e ) { + if( ec != ec_none_e ) { /* - * An EC was raised and was not handled by the statement. - * We know the EC and, for I/O, the current file and its mode. - * Scan declaratives for a match: + * An EC was raised and was not handled by the statement. + * We know the EC and, for I/O, the current file and its mode. + * Scan declaratives for a match: * - EC is enabled or program has a Format 1 Declarative * - EC matches the Declarative's USE statement - * Format 1 declaratives apply only to EC-I-O, whether or not enabled. + * Format 1 declaratives apply only to EC-I-O, whether or not enabled. * Format 1 may be restricted to a particular mode (for all files). - * Format 1 and 3 may be restricted to a set of files. + * Format 1 and 3 may be restricted to a set of files. */ auto f = ec_status.file_status(); - cbl_exception_t raised = { 0, f.ifile, ec, f.mode }; + cbl_exception_t raised = { /*0,*/ f.ifile, ec, f.mode }; bool enabled = enabled_ECs.match(ec); if( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception enabled"); @@ -11506,8 +11560,8 @@ __gg__match_exception( cblc_field_t *index ) p->section); } } - assert(ec != ec_none_e); - } // end EC match logic + assert(ec != ec_none_e); + } // end EC match logic // If a declarative matches the raised exception, return its // symbol_table index. @@ -11581,20 +11635,23 @@ __gg__pseudo_return_flush() extern "C" GCOB_FP128 -__gg__float128_from_location(cblc_field_t *var, unsigned char *location) +__gg__float128_from_location( const cblc_field_t *var, + const unsigned char *location) { GCOB_FP128 retval = 0; switch( var->capacity ) { case 4: { - retval = *(_Float32 *)location; + retval = *reinterpret_cast<_Float32 *>( + const_cast<unsigned char *>(location)); break; } case 8: { - retval = *(_Float64 *)location; + retval = *reinterpret_cast<_Float64 *>( + const_cast<unsigned char *>(location)); break; } @@ -11610,7 +11667,7 @@ __gg__float128_from_location(cblc_field_t *var, unsigned char *location) extern "C" __int128 -__gg__integer_from_float128(cblc_field_t *field) +__gg__integer_from_float128(const cblc_field_t *field) { GCOB_FP128 fvalue = __gg__float128_from_location(field, field->data); // we round() to take care of the possible 2.99999999999... problem. @@ -11729,7 +11786,7 @@ __gg__func_exception_status(cblc_field_t *dest) extern "C" void -__gg__set_exception_file(cblc_file_t *file) +__gg__set_exception_file(const cblc_file_t *file) { ec_type_t ec = local_ec_type_of( file->io_status ); if( ec ) @@ -11748,7 +11805,8 @@ __gg__set_exception_file(cblc_file_t *file) extern "C" void -__gg__func_exception_file(cblc_field_t *dest, cblc_file_t *file) +__gg__func_exception_file(cblc_field_t *dest, + const cblc_file_t *file) { char ach[128]; if( !file ) @@ -11833,7 +11891,7 @@ __gg__set_exception_code(ec_type_t ec, int from_raise_statement) last_exception_statement = __gg__exception_statement ; // These are set in __gg__set_exception_file just before this routine is - // called. In cases where the ec is not a file-i-o operation, we clear + // called. In cases where the ec is not a file-i-o operation, we clear // them here: if( !(ec & ec_io_e) ) { @@ -11932,16 +11990,16 @@ __gg__float128_from_int128(cblc_field_t *destination, extern "C" int -__gg__is_float_infinite(cblc_field_t *source, size_t offset) +__gg__is_float_infinite(const cblc_field_t *source, size_t offset) { int retval = 0; switch(source->capacity) { case 4: - retval = fpclassify( *(_Float32*)(source->data+offset)) == FP_INFINITE; + retval = fpclassify( *reinterpret_cast<_Float32*>(source->data+offset)) == FP_INFINITE; break; case 8: - retval = fpclassify( *(_Float64*)(source->data+offset)) == FP_INFINITE; + retval = fpclassify( *reinterpret_cast<_Float64*>(source->data+offset)) == FP_INFINITE; break; case 16: // retval = *(_Float128*)(source->data+offset) == INFINITY; @@ -11955,10 +12013,10 @@ __gg__is_float_infinite(cblc_field_t *source, size_t offset) extern "C" int -__gg__float32_from_128( cblc_field_t *dest, - size_t dest_offset, - cblc_field_t *source, - size_t source_offset) +__gg__float32_from_128( const cblc_field_t *dest, + size_t dest_offset, + const cblc_field_t *source, + size_t source_offset) { int retval = 0; //_Float128 value = *(_Float128*)(source->data+source_offset); @@ -11970,37 +12028,37 @@ __gg__float32_from_128( cblc_field_t *dest, } else { - *(_Float32 *)(dest->data+dest_offset) = (_Float32)value; + *reinterpret_cast<_Float32 *>(dest->data+dest_offset) = (_Float32)value; } return retval; } extern "C" int -__gg__float32_from_64( cblc_field_t *dest, - size_t dest_offset, - cblc_field_t *source, - size_t source_offset) +__gg__float32_from_64( const cblc_field_t *dest, + size_t dest_offset, + const cblc_field_t *source, + size_t source_offset) { int retval = 0; - _Float64 value = *(_Float64*)(source->data+source_offset); + _Float64 value = *reinterpret_cast<_Float64*>(source->data+source_offset); if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) ) { retval = 1; } else { - *(_Float32 *)(dest->data+dest_offset) = (_Float32)value; + *reinterpret_cast<_Float32 *>(dest->data+dest_offset) = (_Float32)value; } return retval; } extern "C" int -__gg__float64_from_128( cblc_field_t *dest, - size_t dest_offset, - cblc_field_t *source, - size_t source_offset) +__gg__float64_from_128( const cblc_field_t *dest, + size_t dest_offset, + const cblc_field_t *source, + size_t source_offset) { int retval = 0; // _Float128 value = *(_Float128*)(source->data+source_offset); @@ -12012,7 +12070,7 @@ __gg__float64_from_128( cblc_field_t *dest, } else { - *(_Float64 *)(dest->data+dest_offset) = (_Float64)value; + *reinterpret_cast<_Float64 *>(dest->data+dest_offset) = (_Float64)value; } return retval; } @@ -12084,7 +12142,8 @@ __gg__pop_local_variables() extern "C" void -__gg__copy_as_big_endian(unsigned char *dest, unsigned char *source) +__gg__copy_as_big_endian( unsigned char *dest, + const unsigned char *source) { // copy eight bytes of source to dest, flipping the endianness for(size_t i=0; i<8; i++) @@ -12107,7 +12166,7 @@ __gg__codeset_figurative_constants() extern "C" unsigned char * -__gg__get_figconst_data(cblc_field_t *field) +__gg__get_figconst_data(const cblc_field_t *field) { unsigned char *retval = NULL; cbl_figconst_t figconst = (cbl_figconst_t)(size_t)(field->initial); @@ -12192,7 +12251,7 @@ find_in_dirs(const char *dirs, char *unmangled_name, char *mangled_name) { while( !retval ) { - dirent *entry = readdir(dir); + const dirent *entry = readdir(dir); if( !entry ) { break; @@ -12248,7 +12307,7 @@ __gg__function_handle_from_cobpath( char *unmangled_name, char *mangled_name) { handle_executable = dlopen(NULL, RTLD_LAZY); } - if( !retval ) + //if( !retval ) { retval = dlsym(handle_executable, unmangled_name); } @@ -12272,14 +12331,17 @@ __gg__function_handle_from_cobpath( char *unmangled_name, char *mangled_name) extern "C" void -__gg__just_mangle_name( cblc_field_t *field, - char **mangled_name +__gg__just_mangle_name( const cblc_field_t *field, + char **mangled_name ) { static char ach_name[1024]; static char ach_unmangled[1024]; static char ach_mangled[1024]; + assert(field); + assert(field->data); + size_t length; length = field->capacity; memcpy(ach_name, field->data, length); @@ -12293,7 +12355,7 @@ __gg__just_mangle_name( cblc_field_t *field, bool is_pointer = false; - if( (field && field->type == FldPointer) ) + if( field->type == FldPointer ) { is_pointer = true; } @@ -12317,8 +12379,8 @@ __gg__just_mangle_name( cblc_field_t *field, extern "C" void * -__gg__function_handle_from_literal(int program_id, - char *literal) +__gg__function_handle_from_literal(int program_id, + const char *literal) { void *retval = NULL; static char ach_unmangled[1024]; @@ -12346,7 +12408,7 @@ __gg__function_handle_from_literal(int program_id, } PFUNC **pointers_p = it->second; PFUNC *pointers = *pointers_p; - retval = (void *)pointers[function_index]; + retval = reinterpret_cast<void *>(pointers[function_index]); } else { @@ -12358,10 +12420,10 @@ __gg__function_handle_from_literal(int program_id, extern "C" void * -__gg__function_handle_from_name(int program_id, - cblc_field_t *field, - size_t offset, - size_t length ) +__gg__function_handle_from_name(int program_id, + const cblc_field_t *field, + size_t offset, + size_t length ) { void *retval = NULL; static char ach_name[1024]; @@ -12399,7 +12461,7 @@ __gg__function_handle_from_name(int program_id, } PFUNC **pointers_p = it->second; PFUNC *pointers = *pointers_p; - retval = (void *)pointers[function_index]; + retval = reinterpret_cast<void *>(pointers[function_index]); } else { @@ -12435,10 +12497,10 @@ __gg__mirror_range( size_t nrows, cblc_field_t *src, // The row size_t src_o, size_t nspans, // The number of spans - size_t *spans, + const size_t *spans, size_t table, size_t ntbl, - size_t *tbls) + const size_t *tbls) { static std::unordered_map<size_t, size_t> rows_in_table; static std::unordered_map<size_t, size_t> widths_of_table; @@ -12459,7 +12521,7 @@ __gg__mirror_range( size_t nrows, // We need to know the width of one row of this table, which is different // depending on type of src: - cblc_field_t *parent = src; + const cblc_field_t *parent = src; while( parent ) { if( parent->occurs_upper ) @@ -12581,7 +12643,7 @@ __gg__mirror_range( size_t nrows, std::vector<size_t> subtable_spans = spans_in_table [subtable_index]; - unsigned char *subtable_source = source + subtable_offset; + const unsigned char *subtable_source = source + subtable_offset; if( subtable_spans.size() == 0 ) { @@ -12666,15 +12728,17 @@ __gg__deallocate( cblc_field_t *target, { // Target is a pointer. Free the data location int rdigits; - void *ptr = (void *)get_binary_value_local(&rdigits, + size_t addrv = get_binary_value_local(&rdigits, target, target->data + offset, sizeof(void *)); + void *ptr = reinterpret_cast<void *>(addrv); if( ptr ) { free(ptr); // And set the data location to zero - *(char **)(target->data + offset) = NULL; + *static_cast<char **>(static_cast<void *>(target->data + offset)) + = NULL; } } } @@ -12716,17 +12780,18 @@ get_the_byte(cblc_field_t *field) extern "C" void -__gg__allocate( cblc_field_t *first, - size_t first_offset, - int initialized, - int default_byte, - cblc_field_t *f_working_byte, - cblc_field_t *f_local_byte, - cblc_field_t *returning, - size_t returning_offset) +__gg__allocate( cblc_field_t *first, + size_t first_offset, + int initialized, + int default_byte, + cblc_field_t *f_working_byte, + cblc_field_t *f_local_byte, + const cblc_field_t *returning, + size_t returning_offset) { int working_byte = get_the_byte(f_working_byte); int local_byte = get_the_byte(f_local_byte); + int fill_char; unsigned char *retval = NULL; if( first->attr & based_e ) @@ -12734,12 +12799,12 @@ __gg__allocate( cblc_field_t *first, // first is the BASED variable we are allocating memory for if( first->capacity ) { - retval = (unsigned char *)malloc(first->capacity); + retval = static_cast<unsigned char *>(malloc(first->capacity)); + fill_char = 0; if( initialized ) { // This is ISO 2023 ALLOCATE rule 7 (ALL TO VALUE) - int fill_char = 0; if( default_byte >= 0 ) { fill_char = default_byte; @@ -12749,7 +12814,6 @@ __gg__allocate( cblc_field_t *first, else { // This is ISO 2023 ALLOCATE rule 9 (pointers NULL, otherwise OPT_INIT) - int fill_char = 0; if( default_byte >= 0 ) { fill_char = default_byte; @@ -12793,9 +12857,13 @@ __gg__allocate( cblc_field_t *first, tsize /= pof10; if( tsize ) { - retval = (unsigned char *)malloc(tsize); + retval = static_cast<unsigned char *>(malloc(tsize)); + if(!retval) + { + abort(); + } - int fill_char = 0; + fill_char = 0; if( initialized ) { // This is ISO 2023 rule 6 (defaultbyte if specified, else zero) @@ -12834,7 +12902,7 @@ __gg__allocate( cblc_field_t *first, if( returning ) { // 'returning' has to be a FldPointer variable; assign the retval to it. - *(unsigned char **)(returning->data + returning_offset) = retval; + *reinterpret_cast<unsigned char **>(returning->data + returning_offset) = retval; } } @@ -12863,7 +12931,8 @@ void __gg__module_name(cblc_field_t *dest, module_type_t type) { static size_t result_size = 64; - static char *result = (char *)malloc(result_size); + static char *result = static_cast<char *>(malloc(result_size)); + massert(result); strcpy(result, ""); @@ -12952,7 +13021,7 @@ __gg__module_name(cblc_field_t *dest, module_type_t type) if( strlen(result) + module_name_stack[i].substr(1).length() + 4 > result_size) { result_size *= 2; - result = (char *)realloc(result, result_size); + result = static_cast<char *>(realloc(result, result_size)); } strcat(result, module_name_stack[i].substr(1).c_str()); strcat(result, ";"); @@ -13101,39 +13170,42 @@ static char *sv_envname = NULL; extern "C" void -__gg__set_env_name( cblc_field_t *var, - size_t offset, - size_t length ) +__gg__set_env_name( const cblc_field_t *var, + size_t offset, + size_t length ) { free(sv_envname); - sv_envname = (char *)malloc(length+1); + sv_envname = static_cast<char *>(malloc(length+1)); + massert(sv_envname); memcpy(sv_envname, var->data+offset, length); sv_envname[length] = '\0'; } extern "C" void -__gg__set_env_value(cblc_field_t *value, - size_t offset, - size_t length ) +__gg__set_env_value(const cblc_field_t *value, + size_t offset, + size_t length ) { size_t name_length = strlen(sv_envname); size_t value_length = length; - static char *env = NULL; - static size_t env_length = 0; - static char *val = NULL; - static size_t val_length = 0; + static size_t env_length = 16; + static char *env = static_cast<char *>(malloc(env_length+1)); + static size_t val_length = 16; + static char *val = static_cast<char *>(malloc(val_length+1)); if( env_length < name_length+1 ) { env_length = name_length+1; - env = (char *)realloc(env, env_length); + env = static_cast<char *>(realloc(env, env_length)); } if( val_length < value_length+1 ) { val_length = value_length+1; - val = (char *)realloc(val, val_length); + val = static_cast<char *>(realloc(val, val_length)); } + massert(env); + massert(val); // The name and the value arrive in the internal codeset: memcpy(env, sv_envname, name_length); diff --git a/libgcobol/libgcobol.h b/libgcobol/libgcobol.h index f35987d..4aa2cff 100644 --- a/libgcobol/libgcobol.h +++ b/libgcobol/libgcobol.h @@ -39,6 +39,21 @@ Some are also called between source code modules in libgcobol, hence the need here for declarations. */ +extern void __gg__mabort(); + + +// The unnecessary abort() that follows is necessary to make cppcheck be +// aware that massert() actually terminates processing after a failed +// malloc(). +#define massert(p) if(!p){__gg__mabort();abort();} + +// This was part of an exercise to make cppcheck shut up about invalid +// pointer type conversions. +// It was also to avoid having reinterpret_cast<> all over the place. +// So, instead of reinterpret_cast<char *>(VALUE) +// I sometimes use PTRCAST(char, VALUE) +#define PTRCAST(TYPE, VALUE) static_cast<TYPE *>(static_cast<void *>(VALUE)) + extern "C" __int128 __gg__power_of_ten(int n); extern "C" __int128 __gg__dirty_to_binary_source( const char *dirty, @@ -89,22 +104,31 @@ extern "C" char __gg__get_decimal_separator(); extern "C" char __gg__get_decimal_point(); extern "C" char * __gg__get_default_currency_string(); -extern "C" void __gg__clock_gettime(clockid_t clk_id, struct timespec *tp); +struct cbl_timespec + { + /* You keep using that word "portability". I do not think it means what + you think it means. */ + time_t tv_sec; // Seconds. + long tv_nsec; // Nanoseconds. + } ; + +extern "C" void __gg__clock_gettime(clockid_t clk_id, struct cbl_timespec *tp); -extern "C" GCOB_FP128 __gg__float128_from_location(cblc_field_t *var, - unsigned char *location); +extern "C" GCOB_FP128 __gg__float128_from_location( + const cblc_field_t *var, + const unsigned char *location); extern "C" void __gg__adjust_dest_size(cblc_field_t *dest, size_t ncount); extern "C" void __gg__realloc_if_necessary( char **dest, size_t *dest_size, size_t new_size); -extern "C" void __gg__set_exception_file(cblc_file_t *file); +extern "C" void __gg__set_exception_file(const cblc_file_t *file); extern "C" void __gg__internal_to_console_in_place(char *loc, size_t length); -extern "C" __int128 __gg__binary_value_from_qualified_field(int *rdigits, - cblc_field_t *var, +extern "C" __int128 __gg__binary_value_from_qualified_field(int *rdigits, + const cblc_field_t *var, size_t offset, size_t size); -extern "C" GCOB_FP128 __gg__float128_from_qualified_field(cblc_field_t *field, +extern "C" GCOB_FP128 __gg__float128_from_qualified_field(const cblc_field_t *field, size_t offset, size_t size); extern "C" __int128 __gg__integer_from_qualified_field(cblc_field_t *var, diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc index 8349b76..aaa89f5 100644 --- a/libgcobol/valconv.cc +++ b/libgcobol/valconv.cc @@ -71,7 +71,7 @@ __gg__realloc_if_necessary(char **dest, size_t *dest_size, size_t new_size) new_size |= new_size>>16; new_size |= (new_size>>16)>>16; *dest_size = new_size + 1; - *dest = (char *)realloc(*dest, *dest_size); + *dest = static_cast<char *>(realloc(*dest, *dest_size)); } } @@ -79,7 +79,7 @@ extern "C" void __gg__alphabet_create( cbl_encoding_t encoding, size_t alphabet_index, - unsigned char *alphabet, + const unsigned char *alphabet, int low_char, int high_char ) { @@ -222,7 +222,7 @@ Rindex(const char *dest, int length, char ch) extern "C" bool __gg__string_to_numeric_edited( char * const dest, - char *source, // In source characters + const char *source, // In source characters int rdigits, int is_negative, const char *picture) @@ -1222,9 +1222,9 @@ got_float: extern "C" void __gg__string_to_alpha_edited( char *dest, - char *source, + const char *source, int slength, - char *picture) + const char *picture) { // Put the PICTURE into the data area. If the caller didn't leave enough // room, well, poo on them. Said another way; if they specify disaster, diff --git a/libgcobol/valconv.h b/libgcobol/valconv.h index d907e6f..1efb2b9 100644 --- a/libgcobol/valconv.h +++ b/libgcobol/valconv.h @@ -60,18 +60,18 @@ extern "C" void __gg__realloc_if_necessary(char **dest, size_t *dest_size, size_t new_size); void __gg__alphabet_create(cbl_encoding_t encoding, size_t alphabet_index, - unsigned char *alphabet, + const unsigned char *alphabet, int low_char, int high_char ); bool __gg__string_to_numeric_edited(char * const dest, - char *source, // ASCII + const char *source, // ASCII int rdigits, int is_negative, const char *picture); void __gg__string_to_alpha_edited(char *dest, - char *source, + const char *source, int slength, - char *picture); + const char *picture); void __gg__currency_sign_init(); void __gg__currency_sign(int symbol, const char *sign); void __gg__remove_trailing_zeroes(char *p); diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog index 2c044a7..3e68ecb 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,17 @@ +2025-06-04 Tobias Burnus <tburnus@baylibre.com> + Sandra Loosemore <sloosemore@baylibre.com> + + * libgomp.texi (omp_interop_{int,ptr,str,rc_desc}): Add note about + the 'ret_code' type change in OpenMP 6. + +2025-06-03 Jakub Jelinek <jakub@redhat.com> + + PR libgomp/120444 + * testsuite/libgomp.c-c++-common/omp_target_memset-3.c (test_it): + Change ptr argument type from void * to int8_t *. + (main): Change ptr variable type from void * to int8_t * and cast + omp_target_alloc result to the latter type. + 2025-06-02 Tobias Burnus <tburnus@baylibre.com> PR libgomp/120444 diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index 8e487bc..7116fcd 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -3130,6 +3130,11 @@ and Fortran or used with @code{NULL} as argument in C and C++. If successful, In GCC, the effect of running this routine in a @code{target} region that is not the initial device is unspecified. +GCC implements the OpenMP 6.0 version of this function for C and C++, which is not +compatible with its type signature in previous versions of the OpenMP specification. +In older versions, the type @code{int*} was used for the @var{ret_code} argument +in place of a pointer to the enumerated type @code{omp_interop_rc_t}. + @c Implementation remark: In GCC, the Fortran interface differs from the one shown @c below: the function has C binding and @var{interop} and @var{property_id} are @c passed by value, which permits use of the same ABI as the C function. This does @@ -3176,6 +3181,11 @@ and Fortran or used with @code{NULL} as argument in C and C++. If successful, In GCC, the effect of running this routine in a @code{target} region that is not the initial device is unspecified. +GCC implements the OpenMP 6.0 version of this function for C and C++, which is not +compatible with its type signature in previous versions of the OpenMP specification. +In older versions, the type @code{int*} was used for the @var{ret_code} argument +in place of a pointer to the enumerated type @code{omp_interop_rc_t}. + @c Implementation remark: In GCC, the Fortran interface differs from the one shown @c below: the function has C binding and @var{interop} and @var{property_id} are @c passed by value, which permits use of the same ABI as the C function. This does @@ -3222,6 +3232,11 @@ and Fortran or used with @code{NULL} as argument in C and C++. If successful, In GCC, the effect of running this routine in a @code{target} region that is not the initial device is unspecified. +GCC implements the OpenMP 6.0 version of this function for C and C++, which is not +compatible with its type signature in previous versions of the OpenMP specification. +In older versions, the type @code{int*} was used for the @var{ret_code} argument +in place of a pointer to the enumerated type @code{omp_interop_rc_t}. + @c Implementation remark: In GCC, the Fortran interface differs from the one shown @c below: @var{interop} and @var{property_id} are passed by value. This does not @c affect the usage of the function when GCC's @code{omp_lib} module or @@ -3348,6 +3363,11 @@ the @var{ret_code} in human-readable form. The behavior is unspecified if value of @var{ret_code} was not set by an interoperability routine invoked for @var{interop}. +GCC implements the OpenMP 6.0 version of this function for C and C++, which is not +compatible with its type signature in previous versions of the OpenMP specification. +In older versions, the type @code{int} was used for the @var{ret_code} argument +in place of the enumerated type @code{omp_interop_rc_t}. + @item @emph{C/C++}: @multitable @columnfractions .20 .80 @item @emph{Prototype}: @tab @code{const char *omp_get_interop_rc_desc(const omp_interop_t interop, diff --git a/libstdc++-v3/ChangeLog b/libstdc++-v3/ChangeLog index 2a8963e..18d82cb 100644 --- a/libstdc++-v3/ChangeLog +++ b/libstdc++-v3/ChangeLog @@ -1,3 +1,205 @@ +2025-06-05 Jonathan Wakely <jwakely@redhat.com> + + PR libstdc++/120548 + * include/std/format (__formatter_fp::_M_localize): Do not + include a leading sign character in the string to be grouped. + * testsuite/std/format/functions/format.cc: Check grouping when + sign is present in the output. + +2025-06-05 Tomasz Kamiński <tkaminsk@redhat.com> + + PR libstdc++/119152 + * src/c++23/std.cc.in (std::indirect, pmr::indirect) + [__cpp_lib_indirect] + (std::polymorphic, pmr::polymorphic) [__cpp_lib_polymorphic]: Export. + +2025-06-05 Tomasz Kamiński <tkaminsk@redhat.com> + + PR libstdc++/120481 + * include/bits/chrono_io.h (__format::_S_chars): Reorder so it + contains "-{}". + (__format::_S_colon, __format::_S_slash, __format::_S_space) + (__format::_S_plus_minus): Updated starting indicies. + (__format::_S_minus_empty_spec): Define. + (__formatter_chrono::_M_C_y_Y, __formatter_chrono::_M_R_T): + Rework implementation. + (__formatter_chrono::_M_d_e, __formatter_chrono::_M_F) + (__formatter_chrono::_M_m, __formatter_chrono::_M_u_w) + (__formatter_chrono::_M_H_I, __formatter_chrono::_M_p): + Handle multi digits values. + (__formatter_chrono::_S_digit): Return string view. + (__formatter_chrono::_S_str_d1, __formatter_chrono::_S_str_d2) + (__formatter_chrono::_S_fill_two_digits): Define. + * testsuite/std/time/format/empty_spec.cc: Update test for + year_month_day, that uses '%F'. + * testsuite/std/time/format/pr120481.cc: New test. + +2025-06-05 Nathan Myers <ncm@cantrip.org> + + Revert: + 2025-06-04 Nathan Myers <ncm@cantrip.org> + + PR libstdc++/119741 + * include/std/sstream: full implementation, really just + decls, requires clause and plumbing. + * include/bits/version.def, include/bits/version.h: + new preprocessor symbol + __cpp_lib_sstream_from_string_view. + * testsuite/27_io/basic_stringbuf/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_istringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_ostringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_stringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_stringbuf/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_istringstream/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_ostringstream/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_stringstream/cons/wchar_t/string_view.cc: + New tests. + +2025-06-04 Jonathan Wakely <jwakely@redhat.com> + + * testsuite/std/time/format/empty_spec.cc: Only test time zones + for cxx11 string ABI. + +2025-06-04 Jonathan Wakely <jwakely@redhat.com> + + PR libstdc++/99832 + * include/bits/chrono.h (system_clock::to_time_t): Add + always_inline attribute to be agnostic to the underlying type of + time_t. + (system_clock::from_time_t): Add always_inline for consistency + with to_time_t. + * testsuite/20_util/system_clock/99832.cc: New test. + +2025-06-04 Nathan Myers <ncm@cantrip.org> + + PR libstdc++/119741 + * include/std/sstream: full implementation, really just + decls, requires clause and plumbing. + * include/bits/version.def, include/bits/version.h: + new preprocessor symbol + __cpp_lib_sstream_from_string_view. + * testsuite/27_io/basic_stringbuf/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_istringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_ostringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_stringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_stringbuf/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_istringstream/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_ostringstream/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_stringstream/cons/wchar_t/string_view.cc: + New tests. + +2025-06-04 Patrick Palka <ppalka@redhat.com> + + * include/bits/c++config (_GLIBCXX_AUTO_CAST): Define. + * include/bits/iterator_concepts.h (_Decay_copy, __decay_copy): + Remove. + (__member_begin, __adl_begin): Use _GLIBCXX_AUTO_CAST instead of + __decay_copy as per P0849R8. + * include/bits/ranges_base.h (_Begin): Likewise. + (__member_end, __adl_end, _End): Likewise. + (__member_rbegin, __adl_rbegin, _RBegin): Likewise. + (__member_rend, __adl_rend, _Rend): Likewise. + (__member_size, __adl_size, _Size): Likewise. + (_Data): Likewise. + +2025-06-04 Tomasz Kamiński <tkaminsk@redhat.com> + + * testsuite/std/time/format/empty_spec.cc: New tests. + +2025-06-04 Patrick Palka <ppalka@redhat.com> + + * include/bits/ranges_algo.h (__starts_with_fn, starts_with): + Define. + (__ends_with_fn, ends_with): Define. + * include/bits/version.def (ranges_starts_ends_with): Define. + * include/bits/version.h: Regenerate. + * include/std/algorithm: Provide __cpp_lib_ranges_starts_ends_with. + * src/c++23/std.cc.in (ranges::starts_with): Export. + (ranges::ends_with): Export. + * testsuite/25_algorithms/ends_with/1.cc: New test. + * testsuite/25_algorithms/starts_with/1.cc: New test. + +2025-06-04 Jonathan Wakely <jwakely@redhat.com> + + * include/bits/semaphore_base.h (_S_get_current): Replace with + non-static _M_get_current. + (_S_do_try_acquire): Replace with non-static _M_do_try_acquire. + +2025-06-04 Jonathan Wakely <jwakely@redhat.com> + + PR libstdc++/104928 + * include/bits/semaphore_base.h (_S_do_try_acquire): Take old + value by reference. + (_M_acquire): Move _S_do_try_acquire call out of the predicate + and loop on its result. Make the predicate capture and update + the local copy of the value. + (_M_try_acquire_until, _M_try_acquire_for): Likewise. + (_M_try_acquire): Just call _M_try_acquire_for. + * testsuite/30_threads/semaphore/104928-2.cc: New test. + * testsuite/30_threads/semaphore/104928.cc: New test. + +2025-06-04 Tomasz Kamiński <tkaminsk@redhat.com> + + * include/bits/chrono_io.h (__formatter_chrono:_M_s): Add missing + __out argument to format_to call. + * testsuite/std/time/format/empty_spec.cc: New test. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/std/stop_token: Check __glibcxx_jthread instead of + __cplusplus. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/std/type_traits (is_destructible, is_destructible_v): + Define using new built-in. + (is_nothrow_destructible, is_nothrow_destructible_v): Likewise. + (is_trivially_destructible, is_trivially_destructible_v): + Likewise. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/bits/atomic_timed_wait.h (__detail::__wait_until): + Remove incorrect comment. + (__atomic_wait_address_until_v): Do not take address of __args in + call to __detail::__wait_until. Fix return statement to refer to + member of __wait_result_type. + (__atomic_wait_address_for_v): Change parameter type from + time_point to duration. + * src/c++20/atomic.cc (__spin_until_impl): Fix incorrect + return value. Reuse result of first call to clock. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/bits/stl_vector.h (~_Vector_base): Add unreachable + hint for negative capacity and cast to size_t explicitly. + * include/bits/vector.tcc (vector::_M_realloc_append): Use + size() instead of end() - begin(). + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/std/bit (__rotl, __rotr): Use static_cast for + conversion from int to unsigned. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * src/c++23/std.cc.in: Remove redundant checks for feature test + macros that are always true. + 2025-06-02 Jonathan Wakely <jwakely@redhat.com> * include/bits/basic_string.h (basic_string::size): Remove space diff --git a/libstdc++-v3/include/bits/atomic_timed_wait.h b/libstdc++-v3/include/bits/atomic_timed_wait.h index 230afbc..30f7ff6 100644 --- a/libstdc++-v3/include/bits/atomic_timed_wait.h +++ b/libstdc++-v3/include/bits/atomic_timed_wait.h @@ -87,7 +87,6 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION __wait_until_impl(const void* __addr, __wait_args_base& __args, const __wait_clock_t::duration& __atime); - // Returns {true, val} if wait ended before a timeout. template<typename _Clock, typename _Dur> __wait_result_type __wait_until(const void* __addr, __wait_args_base& __args, @@ -157,9 +156,12 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION const chrono::time_point<_Clock, _Dur>& __atime, bool __bare_wait = false) noexcept { +#ifndef _GLIBCXX_HAVE_PLATFORM_TIMED_WAIT + __glibcxx_assert(false); // This function can't be used for proxy wait. +#endif __detail::__wait_args __args{ __addr, __old, __order, __bare_wait }; - auto __res = __detail::__wait_until(__addr, &__args, __atime); - return __res.first; // C++26 will also return last observed __val + auto __res = __detail::__wait_until(__addr, __args, __atime); + return !__res._M_timeout; // C++26 will also return last observed __val } template<typename _Tp, typename _ValFn, @@ -203,9 +205,12 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION __atomic_wait_address_for_v(const __detail::__platform_wait_t* __addr, __detail::__platform_wait_t __old, int __order, - const chrono::time_point<_Rep, _Period>& __rtime, + const chrono::duration<_Rep, _Period>& __rtime, bool __bare_wait = false) noexcept { +#ifndef _GLIBCXX_HAVE_PLATFORM_TIMED_WAIT + __glibcxx_assert(false); // This function can't be used for proxy wait. +#endif __detail::__wait_args __args{ __addr, __old, __order, __bare_wait }; auto __res = __detail::__wait_for(__addr, __args, __rtime); return !__res._M_timeout; // C++26 will also return last observed __val diff --git a/libstdc++-v3/include/bits/atomic_wait.h b/libstdc++-v3/include/bits/atomic_wait.h index 815726c..9515147 100644 --- a/libstdc++-v3/include/bits/atomic_wait.h +++ b/libstdc++-v3/include/bits/atomic_wait.h @@ -249,12 +249,16 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION // C++26 will return __val } + // Wait on __addr while *__addr == __old is true. inline void __atomic_wait_address_v(const __detail::__platform_wait_t* __addr, __detail::__platform_wait_t __old, - int __order) + int __order, bool __bare_wait = false) { - __detail::__wait_args __args{ __addr, __old, __order }; +#ifndef _GLIBCXX_HAVE_PLATFORM_WAIT + __glibcxx_assert(false); // This function can't be used for proxy wait. +#endif + __detail::__wait_args __args{ __addr, __old, __order, __bare_wait }; // C++26 will not ignore the return value here __detail::__wait_impl(__addr, __args); } diff --git a/libstdc++-v3/include/bits/c++config b/libstdc++-v3/include/bits/c++config index 676f5ee..eec3a4a 100644 --- a/libstdc++-v3/include/bits/c++config +++ b/libstdc++-v3/include/bits/c++config @@ -273,6 +273,12 @@ #define _GLIBCXX_NOEXCEPT_QUAL #endif +#if __cpp_auto_cast +# define _GLIBCXX_AUTO_CAST(X) auto(X) +#else +# define _GLIBCXX_AUTO_CAST(X) ::std::__decay_t<decltype((X))>(X) +#endif + // Macro for extern template, ie controlling template linkage via use // of extern keyword on template declaration. As documented in the g++ // manual, it inhibits all implicit instantiations and is used diff --git a/libstdc++-v3/include/bits/chrono.h b/libstdc++-v3/include/bits/chrono.h index fad2162..8de8e75 100644 --- a/libstdc++-v3/include/bits/chrono.h +++ b/libstdc++-v3/include/bits/chrono.h @@ -1244,6 +1244,7 @@ _GLIBCXX_BEGIN_INLINE_ABI_NAMESPACE(_V2) now() noexcept; // Map to C API + [[__gnu__::__always_inline__]] static std::time_t to_time_t(const time_point& __t) noexcept { @@ -1251,6 +1252,7 @@ _GLIBCXX_BEGIN_INLINE_ABI_NAMESPACE(_V2) (__t.time_since_epoch()).count()); } + [[__gnu__::__always_inline__]] static time_point from_time_t(std::time_t __t) noexcept { diff --git a/libstdc++-v3/include/bits/chrono_io.h b/libstdc++-v3/include/bits/chrono_io.h index 346eb8b..c5c5e4b 100644 --- a/libstdc++-v3/include/bits/chrono_io.h +++ b/libstdc++-v3/include/bits/chrono_io.h @@ -785,11 +785,12 @@ namespace __format } static constexpr const _CharT* _S_chars - = _GLIBCXX_WIDEN("0123456789+-:/ {}"); - static constexpr const _CharT* _S_plus_minus = _S_chars + 10; - static constexpr _CharT _S_colon = _S_chars[12]; - static constexpr _CharT _S_slash = _S_chars[13]; - static constexpr _CharT _S_space = _S_chars[14]; + = _GLIBCXX_WIDEN("0123456789:/ +-{}"); + static constexpr _CharT _S_colon = _S_chars[10]; + static constexpr _CharT _S_slash = _S_chars[11]; + static constexpr _CharT _S_space = _S_chars[12]; + static constexpr const _CharT* _S_plus_minus = _S_chars + 13; + static constexpr const _CharT* _S_minus_empty_spec = _S_chars + 14; static constexpr const _CharT* _S_empty_spec = _S_chars + 15; template<typename _OutIter> @@ -941,33 +942,39 @@ namespace __format __conv, __mod); } - basic_string<_CharT> __s; int __yi = (int)__y; const bool __is_neg = __yi < 0; __yi = __builtin_abs(__yi); + int __ci = __yi / 100; + // For floored division -123//100 is -2 and -100//100 is -1 + if (__conv == 'C' && __is_neg && (__ci * 100) != __yi) [[unlikely]] + ++__ci; - if (__conv == 'Y' || __conv == 'C') + if (__conv != 'y' && __ci >= 100) [[unlikely]] { - int __ci = __yi / 100; - if (__is_neg) [[unlikely]] + using _FmtStr = _Runtime_format_string<_CharT>; + __string_view __fs = _S_minus_empty_spec + !__is_neg; + __out = std::format_to(std::move(__out), _FmtStr(__fs), + __conv == 'C' ? __ci : __yi); + } + else + { + _CharT __buf[5]; + __buf[0] = _S_plus_minus[1]; + __string_view __sv(__buf + 3, __buf + 3); + if (__conv != 'y') { - __s.assign(1, _S_plus_minus[1]); - // For floored division -123//100 is -2 and -100//100 is -1 - if (__conv == 'C' && (__ci * 100) != __yi) - ++__ci; + _S_fill_two_digits(__buf + 1, __ci); + __sv = __string_view(__buf + !__is_neg, __buf + 3); } - if (__ci >= 100) [[unlikely]] + if (__conv != 'C') { - __s += std::format(_S_empty_spec, __ci / 100); - __ci %= 100; + _S_fill_two_digits(__buf + 3, __yi % 100); + __sv = __string_view(__sv.data(), __buf + 5); } - __s += _S_two_digits(__ci); + __out = __format::__write(std::move(__out), __sv); } - - if (__conv == 'Y' || __conv == 'y') - __s += _S_two_digits(__yi % 100); - - return __format::__write(std::move(__out), __string_view(__s)); + return std::move(__out); } template<typename _Tp, typename _FormatContext> @@ -976,16 +983,30 @@ namespace __format _FormatContext&) const { auto __ymd = _S_date(__t); - basic_string<_CharT> __s; -#if ! _GLIBCXX_USE_CXX11_ABI - __s.reserve(8); -#endif - __s = _S_two_digits((unsigned)__ymd.month()); - __s += _S_slash; - __s += _S_two_digits((unsigned)__ymd.day()); - __s += _S_slash; - __s += _S_two_digits(__builtin_abs((int)__ymd.year()) % 100); - return __format::__write(std::move(__out), __string_view(__s)); + auto __di = (unsigned)__ymd.day(); + auto __mi = (unsigned)__ymd.month(); + auto __yi = __builtin_abs((int)__ymd.year()) % 100; + + if (__mi >= 100 || __di >= 100) [[unlikely]] + { + using _FmtStr = _Runtime_format_string<_CharT>; + __string_view __fs = _GLIBCXX_WIDEN("{:02d}/{:02d}/{:02d}"); + __out = std::format_to(std::move(__out), _FmtStr(__fs), + __mi, __di, __yi); + } + else + { + _CharT __buf[8]; + __buf[2] = _S_slash; + __buf[5] = _S_slash; + __string_view __sv(__buf, __buf + 8); + + _S_fill_two_digits(__buf, __mi); + _S_fill_two_digits(__buf + 3, __di); + _S_fill_two_digits(__buf + 6, __yi); + __out = __format::__write(std::move(__out), __sv); + } + return std::move(__out); } template<typename _Tp, typename _FormatContext> @@ -1010,12 +1031,12 @@ namespace __format (char)__conv, 'O'); } - auto __sv = _S_two_digits(__i); - _CharT __buf[2]; + _CharT __buf[3]; + auto __sv = _S_str_d2(__buf, __i); if (__conv == _CharT('e') && __i < 10) { - __buf[0] = _S_space; __buf[1] = __sv[1]; + __buf[0] = _S_space; __sv = {__buf, 2}; } return __format::__write(std::move(__out), __sv); @@ -1027,16 +1048,35 @@ namespace __format _FormatContext&) const { auto __ymd = _S_date(__t); - auto __s = std::format(_GLIBCXX_WIDEN("{:04d}- - "), - (int)__ymd.year()); - auto __sv = _S_two_digits((unsigned)__ymd.month()); - __s[__s.size() - 5] = __sv[0]; - __s[__s.size() - 4] = __sv[1]; - __sv = _S_two_digits((unsigned)__ymd.day()); - __s[__s.size() - 2] = __sv[0]; - __s[__s.size() - 1] = __sv[1]; - __sv = __s; - return __format::__write(std::move(__out), __sv); + auto __di = (unsigned)__ymd.day(); + auto __mi = (unsigned)__ymd.month(); + auto __yi = (int)__ymd.year(); + const bool __is_neg = __yi < 0; + __yi = __builtin_abs(__yi); + + if (__yi >= 10000 || __mi >= 100 || __di >= 100) [[unlikely]] + { + using _FmtStr = _Runtime_format_string<_CharT>; + __string_view __fs + = _GLIBCXX_WIDEN("-{:04d}-{:02d}-{:02d}") + !__is_neg; + __out = std::format_to(std::move(__out), _FmtStr(__fs), + __yi, __mi, __di); + } + else + { + _CharT __buf[11]; + __buf[0] = _S_plus_minus[1]; + __buf[5] = _S_plus_minus[1]; + __buf[8] = _S_plus_minus[1]; + __string_view __sv(__buf + !__is_neg, __buf + 11); + + _S_fill_two_digits(__buf + 1, __yi / 100); + _S_fill_two_digits(__buf + 3, __yi % 100); + _S_fill_two_digits(__buf + 6, __mi); + _S_fill_two_digits(__buf + 9, __di); + __out = __format::__write(std::move(__out), __sv); + } + return std::move(__out); } template<typename _Tp, typename _FormatContext> @@ -1079,11 +1119,13 @@ namespace __format if (__conv == _CharT('I')) { + __i %= 12; if (__i == 0) __i = 12; - else if (__i > 12) - __i -= 12; } + else if (__i >= 100) [[unlikely]] + return std::format_to(std::move(__out), _S_empty_spec, __i); + return __format::__write(std::move(__out), _S_two_digits(__i)); } @@ -1136,7 +1178,8 @@ namespace __format 'm', 'O'); } - return __format::__write(std::move(__out), _S_two_digits(__i)); + _CharT __buf[3]; + return __format::__write(std::move(__out), _S_str_d2(__buf, __i)); } template<typename _Tp, typename _FormatContext> @@ -1169,12 +1212,15 @@ namespace __format { // %p The locale's equivalent of the AM/PM designations. auto __hms = _S_hms(__t); + auto __hi = __hms.hours().count(); + if (__hi >= 24) [[unlikely]] + __hi %= 24; + locale __loc = _M_locale(__ctx); const auto& __tp = use_facet<__timepunct<_CharT>>(__loc); const _CharT* __ampm[2]; __tp._M_am_pm(__ampm); - return _M_write(std::move(__out), __loc, - __ampm[__hms.hours().count() >= 12]); + return _M_write(std::move(__out), __loc, __ampm[__hi >= 12]); } template<typename _Tp, typename _FormatContext> @@ -1222,19 +1268,25 @@ namespace __format // %R Equivalent to %H:%M // %T Equivalent to %H:%M:%S auto __hms = _S_hms(__t); + auto __hi = __hms.hours().count(); - auto __s = std::format(_GLIBCXX_WIDEN("{:02d}:00"), - __hms.hours().count()); - auto __sv = _S_two_digits(__hms.minutes().count()); - __s[__s.size() - 2] = __sv[0]; - __s[__s.size() - 1] = __sv[1]; - __sv = __s; - __out = __format::__write(std::move(__out), __sv); - if (__secs) + _CharT __buf[6]; + __buf[2] = _S_colon; + __buf[5] = _S_colon; + __string_view __sv(__buf, 5 + __secs); + + if (__hi >= 100) [[unlikely]] { - *__out++ = _S_colon; - __out = _M_S(__hms, std::move(__out), __ctx); + __out = std::format_to(std::move(__out), _S_empty_spec, __hi); + __sv.remove_prefix(2); } + else + _S_fill_two_digits(__buf, __hi); + + _S_fill_two_digits(__buf + 3, __hms.minutes().count()); + __out = __format::__write(std::move(__out), __sv); + if (__secs) + __out = _M_S(__hms, std::move(__out), __ctx); return __out; } @@ -1296,7 +1348,8 @@ namespace __format else { auto __str = std::format(_S_empty_spec, __ss.count()); - __out = std::format_to(_GLIBCXX_WIDEN("{:0>{}s}"), + __out = std::format_to(std::move(__out), + _GLIBCXX_WIDEN("{:0>{}s}"), __str, __hms.fractional_width); } @@ -1330,8 +1383,8 @@ namespace __format unsigned __wdi = __conv == 'u' ? __wd.iso_encoding() : __wd.c_encoding(); - const _CharT __d = _S_digit(__wdi); - return __format::__write(std::move(__out), __string_view(&__d, 1)); + _CharT __buf[3]; + return __format::__write(std::move(__out), _S_str_d1(__buf, __wdi)); } template<typename _Tp, typename _FormatContext> @@ -1516,12 +1569,12 @@ namespace __format // %% handled in _M_format - // A single digit character in the range '0'..'9'. - static _CharT + // A string view of single digit character, "0".."9". + static basic_string_view<_CharT> _S_digit(int __n) noexcept { // Extra 9s avoid past-the-end read on bad input. - return _GLIBCXX_WIDEN("0123456789999999")[__n & 0xf]; + return { _GLIBCXX_WIDEN("0123456789999999") + (__n & 0xf), 1 }; } // A string view of two digit characters, "00".."99". @@ -1540,6 +1593,41 @@ namespace __format }; } + [[__gnu__::__always_inline__]] + // Fills __buf[0] and __buf[1] with 2 digit value of __n. + static void + _S_fill_two_digits(_CharT* __buf, unsigned __n) + { + auto __sv = _S_two_digits(__n); + __buf[0] = __sv[0]; + __buf[1] = __sv[1]; + } + + [[__gnu__::__always_inline__]] + // Returns decimal representation of __n. + // Returned string_view may point to __buf. + static basic_string_view<_CharT> + _S_str_d1(span<_CharT, 3> __buf, unsigned __n) + { + if (__n < 10) [[likely]] + return _S_digit(__n); + return _S_str_d2(__buf, __n); + } + + [[__gnu__::__always_inline__]] + // Returns decimal representation of __n, padded to 2 digits. + // Returned string_view may point to __buf. + static basic_string_view<_CharT> + _S_str_d2(span<_CharT, 3> __buf, unsigned __n) + { + if (__n < 100) [[likely]] + return _S_two_digits(__n); + + _S_fill_two_digits(__buf.data(), __n / 10); + __buf[2] = _S_digit(__n % 10)[0]; + return __string_view(__buf.data(), 3); + } + // Accessors for the components of chrono types: // Returns a hh_mm_ss. @@ -2856,9 +2944,14 @@ namespace __detail basic_ostream<_CharT, _Traits>& operator<<(basic_ostream<_CharT, _Traits>& __os, const sys_info& __i) { - __os << '[' << __i.begin << ',' << __i.end - << ',' << hh_mm_ss(__i.offset) << ',' << __i.save - << ',' << __i.abbrev << ']'; + // n.b. only decimal separator is locale dependent for specifiers + // used below, as sys_info uses seconds and minutes duration, the + // output is locale-independent. + constexpr auto* __fs + = _GLIBCXX_WIDEN("[{0:%F %T},{1:%F %T},{2:%T},{3:%Q%q},{0:%Z}]"); + local_seconds __lb(__i.begin.time_since_epoch()); + __os << std::format(__fs, local_time_format(__lb, &__i.abbrev), + __i.end, __i.offset, __i.save); return __os; } @@ -2867,19 +2960,19 @@ namespace __detail basic_ostream<_CharT, _Traits>& operator<<(basic_ostream<_CharT, _Traits>& __os, const local_info& __li) { - __os << '['; + __os << __format::_Separators<_CharT>::_S_squares()[0]; if (__li.result == local_info::unique) __os << __li.first; else { if (__li.result == local_info::nonexistent) - __os << "nonexistent"; + __os << _GLIBCXX_WIDEN("nonexistent"); else - __os << "ambiguous"; - __os << " local time between " << __li.first; - __os << " and " << __li.second; + __os << _GLIBCXX_WIDEN("ambiguous"); + __os << _GLIBCXX_WIDEN(" local time between ") << __li.first; + __os << _GLIBCXX_WIDEN(" and ") << __li.second; } - __os << ']'; + __os << __format::_Separators<_CharT>::_S_squares()[1]; return __os; } diff --git a/libstdc++-v3/include/bits/iterator_concepts.h b/libstdc++-v3/include/bits/iterator_concepts.h index 3b73ff9..d31e4f1 100644 --- a/libstdc++-v3/include/bits/iterator_concepts.h +++ b/libstdc++-v3/include/bits/iterator_concepts.h @@ -1022,19 +1022,10 @@ namespace ranges { using std::__detail::__class_or_enum; - struct _Decay_copy final - { - template<typename _Tp> - constexpr decay_t<_Tp> - operator()(_Tp&& __t) const - noexcept(is_nothrow_convertible_v<_Tp, decay_t<_Tp>>) - { return std::forward<_Tp>(__t); } - } inline constexpr __decay_copy{}; - template<typename _Tp> concept __member_begin = requires(_Tp& __t) { - { __decay_copy(__t.begin()) } -> input_or_output_iterator; + { _GLIBCXX_AUTO_CAST(__t.begin()) } -> input_or_output_iterator; }; // Poison pill so that unqualified lookup doesn't find std::begin. @@ -1044,7 +1035,7 @@ namespace ranges concept __adl_begin = __class_or_enum<remove_reference_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(begin(__t)) } -> input_or_output_iterator; + { _GLIBCXX_AUTO_CAST(begin(__t)) } -> input_or_output_iterator; }; // Simplified version of std::ranges::begin that only supports lvalues, diff --git a/libstdc++-v3/include/bits/ranges_algo.h b/libstdc++-v3/include/bits/ranges_algo.h index 7b14084..a62c3cd 100644 --- a/libstdc++-v3/include/bits/ranges_algo.h +++ b/libstdc++-v3/include/bits/ranges_algo.h @@ -438,6 +438,254 @@ namespace ranges inline constexpr __search_n_fn search_n{}; +#if __glibcxx_ranges_starts_ends_with // C++ >= 23 + struct __starts_with_fn + { + template<input_iterator _Iter1, sentinel_for<_Iter1> _Sent1, + input_iterator _Iter2, sentinel_for<_Iter2> _Sent2, + typename _Pred = ranges::equal_to, + typename _Proj1 = identity, typename _Proj2 = identity> + requires indirectly_comparable<_Iter1, _Iter2, _Pred, _Proj1, _Proj2> + constexpr bool + operator()(_Iter1 __first1, _Sent1 __last1, + _Iter2 __first2, _Sent2 __last2, _Pred __pred = {}, + _Proj1 __proj1 = {}, _Proj2 __proj2 = {}) const + { + iter_difference_t<_Iter1> __n1 = -1; + iter_difference_t<_Iter2> __n2 = -1; + if constexpr (sized_sentinel_for<_Sent1, _Iter1>) + __n1 = __last1 - __first1; + if constexpr (sized_sentinel_for<_Sent2, _Iter2>) + __n2 = __last2 - __first2; + return _S_impl(std::move(__first1), __last1, __n1, + std::move(__first2), __last2, __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + template<input_range _Range1, input_range _Range2, + typename _Pred = ranges::equal_to, + typename _Proj1 = identity, typename _Proj2 = identity> + requires indirectly_comparable<iterator_t<_Range1>, iterator_t<_Range2>, + _Pred, _Proj1, _Proj2> + constexpr bool + operator()(_Range1&& __r1, _Range2&& __r2, _Pred __pred = {}, + _Proj1 __proj1 = {}, _Proj2 __proj2 = {}) const + { + range_difference_t<_Range1> __n1 = -1; + range_difference_t<_Range2> __n2 = -1; + if constexpr (sized_range<_Range1>) + __n1 = ranges::size(__r1); + if constexpr (sized_range<_Range2>) + __n2 = ranges::size(__r2); + return _S_impl(ranges::begin(__r1), ranges::end(__r1), __n1, + ranges::begin(__r2), ranges::end(__r2), __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + private: + template<typename _Iter1, typename _Sent1, typename _Iter2, typename _Sent2, + typename _Pred, + typename _Proj1, typename _Proj2> + static constexpr bool + _S_impl(_Iter1 __first1, _Sent1 __last1, iter_difference_t<_Iter1> __n1, + _Iter2 __first2, _Sent2 __last2, iter_difference_t<_Iter2> __n2, + _Pred __pred, _Proj1 __proj1, _Proj2 __proj2) + { + if (__first2 == __last2) [[unlikely]] + return true; + else if (__n1 == -1 || __n2 == -1) + return ranges::mismatch(std::move(__first1), __last1, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)).in2 == __last2; + else if (__n1 < __n2) + return false; + else if constexpr (random_access_iterator<_Iter1>) + return ranges::equal(__first1, __first1 + iter_difference_t<_Iter1>(__n2), + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + else + return ranges::equal(counted_iterator(std::move(__first1), + iter_difference_t<_Iter1>(__n2)), + default_sentinel, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + friend struct __ends_with_fn; + }; + + inline constexpr __starts_with_fn starts_with{}; + + struct __ends_with_fn + { + template<input_iterator _Iter1, sentinel_for<_Iter1> _Sent1, + input_iterator _Iter2, sentinel_for<_Iter2> _Sent2, + typename _Pred = ranges::equal_to, + typename _Proj1 = identity, typename _Proj2 = identity> + requires (forward_iterator<_Iter1> || sized_sentinel_for<_Sent1, _Iter1>) + && (forward_iterator<_Iter2> || sized_sentinel_for<_Sent2, _Iter2>) + && indirectly_comparable<_Iter1, _Iter2, _Pred, _Proj1, _Proj2> + constexpr bool + operator()(_Iter1 __first1, _Sent1 __last1, + _Iter2 __first2, _Sent2 __last2, _Pred __pred = {}, + _Proj1 __proj1 = {}, _Proj2 __proj2 = {}) const + { + iter_difference_t<_Iter1> __n1 = -1; + iter_difference_t<_Iter2> __n2 = -1; + if constexpr (sized_sentinel_for<_Sent1, _Iter1>) + __n1 = __last1 - __first1; + if constexpr (sized_sentinel_for<_Sent2, _Iter2>) + __n2 = __last2 - __first2; + return _S_impl(std::move(__first1), __last1, __n1, + std::move(__first2), __last2, __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + template<input_range _Range1, input_range _Range2, + typename _Pred = ranges::equal_to, + typename _Proj1 = identity, typename _Proj2 = identity> + requires (forward_range<_Range1> || sized_range<_Range1>) + && (forward_range<_Range2> || sized_range<_Range2>) + && indirectly_comparable<iterator_t<_Range1>, iterator_t<_Range2>, + _Pred, _Proj1, _Proj2> + constexpr bool + operator()(_Range1&& __r1, _Range2&& __r2, _Pred __pred = {}, + _Proj1 __proj1 = {}, _Proj2 __proj2 = {}) const + { + range_difference_t<_Range1> __n1 = -1; + range_difference_t<_Range2> __n2 = -1; + if constexpr (sized_range<_Range1>) + __n1 = ranges::size(__r1); + if constexpr (sized_range<_Range2>) + __n2 = ranges::size(__r2); + return _S_impl(ranges::begin(__r1), ranges::end(__r1), __n1, + ranges::begin(__r2), ranges::end(__r2), __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + private: + template<typename _Iter1, typename _Sent1, + typename _Iter2, typename _Sent2, + typename _Pred, + typename _Proj1, typename _Proj2> + static constexpr bool + _S_impl(_Iter1 __first1, _Sent1 __last1, iter_difference_t<_Iter1> __n1, + _Iter2 __first2, _Sent2 __last2, iter_difference_t<_Iter2> __n2, + _Pred __pred, _Proj1 __proj1, _Proj2 __proj2) + { + if constexpr (!random_access_iterator<_Iter1> + && bidirectional_iterator<_Iter1> && same_as<_Iter1, _Sent1> + && bidirectional_iterator<_Iter2> && same_as<_Iter2, _Sent2>) + return starts_with._S_impl(std::make_reverse_iterator(__last1), + std::make_reverse_iterator(__first1), + __n1, + std::make_reverse_iterator(__last2), + std::make_reverse_iterator(__first2), + __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + + if (__first2 == __last2) [[unlikely]] + return true; + + if constexpr (forward_iterator<_Iter2>) + if (__n2 == -1) + __n2 = ranges::distance(__first2, __last2); + + // __glibcxx_assert(__n2 != -1); + + if (__n1 != -1) + { + if (__n1 < __n2) + return false; + auto __shift = __n1 - iter_difference_t<_Iter1>(__n2); + if (random_access_iterator<_Iter1> + || !bidirectional_iterator<_Iter1> + || !same_as<_Iter1, _Sent1> + || __shift < __n2) + { + ranges::advance(__first1, __shift); + return ranges::equal(std::move(__first1), __last1, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + } + + if constexpr (bidirectional_iterator<_Iter1> && same_as<_Iter1, _Sent1>) + { + _Iter1 __it1 = __last1; + if (__n1 != -1) + ranges::advance(__it1, -iter_difference_t<_Iter1>(__n2)); + else + { + // We can't use ranges::advance if the haystack size is + // unknown, since we need to detect and return false if + // it's smaller than the needle. + iter_difference_t<_Iter2> __m = __n2; + while (__m != 0 && __it1 != __first1) + { + --__m; + --__it1; + } + if (__m != 0) + return false; + } + return ranges::equal(__it1, __last1, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + else if constexpr (forward_iterator<_Iter1>) + { + // __glibcxx_assert(__n1 == -1); + _Iter1 __prev_first1; + __n1 = 0; + while (true) + { + iter_difference_t<_Iter2> __m = __n2; + _Iter1 __it1 = __first1; + while (__m != 0 && __it1 != __last1) + { + ++__n1; + --__m; + ++__it1; + } + if (__m != 0) + { + // __glibcxx_assert(__it1 == __last1); + if (__n1 < __n2) + return false; + __first1 = ranges::next(__prev_first1, + iter_difference_t<_Iter1>(__n2 - __m)); + break; + } + __prev_first1 = __first1; + __first1 = __it1; + } + return ranges::equal(__first1, __last1, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + else + // If the haystack is non-forward then it must be sized, in which case + // we already returned via the __n1 != 1 case. + __builtin_unreachable(); + } + + }; + + inline constexpr __ends_with_fn ends_with{}; +#endif // __glibcxx_ranges_starts_ends_with + struct __find_end_fn { template<forward_iterator _Iter1, sentinel_for<_Iter1> _Sent1, diff --git a/libstdc++-v3/include/bits/ranges_base.h b/libstdc++-v3/include/bits/ranges_base.h index dde1649..c09f729 100644 --- a/libstdc++-v3/include/bits/ranges_base.h +++ b/libstdc++-v3/include/bits/ranges_base.h @@ -119,9 +119,9 @@ namespace ranges if constexpr (is_array_v<remove_reference_t<_Tp>>) return true; else if constexpr (__member_begin<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().begin())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().begin())); else - return noexcept(__decay_copy(begin(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(begin(std::declval<_Tp&>()))); } public: @@ -146,7 +146,7 @@ namespace ranges template<typename _Tp> concept __member_end = requires(_Tp& __t) { - { __decay_copy(__t.end()) } -> sentinel_for<__range_iter_t<_Tp>>; + { _GLIBCXX_AUTO_CAST(__t.end()) } -> sentinel_for<__range_iter_t<_Tp>>; }; // Poison pill so that unqualified lookup doesn't find std::end. @@ -156,7 +156,7 @@ namespace ranges concept __adl_end = __class_or_enum<remove_reference_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(end(__t)) } -> sentinel_for<__range_iter_t<_Tp>>; + { _GLIBCXX_AUTO_CAST(end(__t)) } -> sentinel_for<__range_iter_t<_Tp>>; }; struct _End @@ -169,9 +169,9 @@ namespace ranges if constexpr (is_bounded_array_v<remove_reference_t<_Tp>>) return true; else if constexpr (__member_end<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().end())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().end())); else - return noexcept(__decay_copy(end(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(end(std::declval<_Tp&>()))); } public: @@ -196,7 +196,7 @@ namespace ranges template<typename _Tp> concept __member_rbegin = requires(_Tp& __t) { - { __decay_copy(__t.rbegin()) } -> input_or_output_iterator; + { _GLIBCXX_AUTO_CAST(__t.rbegin()) } -> input_or_output_iterator; }; void rbegin() = delete; @@ -205,7 +205,7 @@ namespace ranges concept __adl_rbegin = __class_or_enum<remove_reference_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(rbegin(__t)) } -> input_or_output_iterator; + { _GLIBCXX_AUTO_CAST(rbegin(__t)) } -> input_or_output_iterator; }; template<typename _Tp> @@ -223,9 +223,9 @@ namespace ranges _S_noexcept() { if constexpr (__member_rbegin<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().rbegin())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().rbegin())); else if constexpr (__adl_rbegin<_Tp>) - return noexcept(__decay_copy(rbegin(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(rbegin(std::declval<_Tp&>()))); else { if constexpr (noexcept(_End{}(std::declval<_Tp&>()))) @@ -258,7 +258,7 @@ namespace ranges template<typename _Tp> concept __member_rend = requires(_Tp& __t) { - { __decay_copy(__t.rend()) } + { _GLIBCXX_AUTO_CAST(__t.rend()) } -> sentinel_for<decltype(_RBegin{}(std::forward<_Tp>(__t)))>; }; @@ -268,7 +268,7 @@ namespace ranges concept __adl_rend = __class_or_enum<remove_reference_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(rend(__t)) } + { _GLIBCXX_AUTO_CAST(rend(__t)) } -> sentinel_for<decltype(_RBegin{}(std::forward<_Tp>(__t)))>; }; @@ -280,9 +280,9 @@ namespace ranges _S_noexcept() { if constexpr (__member_rend<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().rend())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().rend())); else if constexpr (__adl_rend<_Tp>) - return noexcept(__decay_copy(rend(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(rend(std::declval<_Tp&>()))); else { if constexpr (noexcept(_Begin{}(std::declval<_Tp&>()))) @@ -316,7 +316,7 @@ namespace ranges concept __member_size = !disable_sized_range<remove_cvref_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(__t.size()) } -> __detail::__is_integer_like; + { _GLIBCXX_AUTO_CAST(__t.size()) } -> __detail::__is_integer_like; }; void size() = delete; @@ -326,7 +326,7 @@ namespace ranges && !disable_sized_range<remove_cvref_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(size(__t)) } -> __detail::__is_integer_like; + { _GLIBCXX_AUTO_CAST(size(__t)) } -> __detail::__is_integer_like; }; template<typename _Tp> @@ -351,9 +351,9 @@ namespace ranges if constexpr (is_bounded_array_v<remove_reference_t<_Tp>>) return true; else if constexpr (__member_size<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().size())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().size())); else if constexpr (__adl_size<_Tp>) - return noexcept(__decay_copy(size(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(size(std::declval<_Tp&>()))); else if constexpr (__sentinel_size<_Tp>) return noexcept(_End{}(std::declval<_Tp&>()) - _Begin{}(std::declval<_Tp&>())); @@ -463,7 +463,7 @@ namespace ranges template<typename _Tp> concept __member_data = requires(_Tp& __t) { - { __decay_copy(__t.data()) } -> __pointer_to_object; + { _GLIBCXX_AUTO_CAST(__t.data()) } -> __pointer_to_object; }; template<typename _Tp> @@ -477,7 +477,7 @@ namespace ranges _S_noexcept() { if constexpr (__member_data<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().data())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().data())); else return noexcept(_Begin{}(std::declval<_Tp&>())); } diff --git a/libstdc++-v3/include/bits/semaphore_base.h b/libstdc++-v3/include/bits/semaphore_base.h index 5b5a1c9..ebbc9a8 100644 --- a/libstdc++-v3/include/bits/semaphore_base.h +++ b/libstdc++-v3/include/bits/semaphore_base.h @@ -46,87 +46,233 @@ namespace std _GLIBCXX_VISIBILITY(default) { _GLIBCXX_BEGIN_NAMESPACE_VERSION - template<bool _Platform_wait> - struct __semaphore_base + struct __semaphore_impl { - using __count_type = __conditional_t<_Platform_wait, - __detail::__platform_wait_t, - ptrdiff_t>; + using __count_type = ptrdiff_t; static constexpr ptrdiff_t _S_max = __gnu_cxx::__int_traits<__count_type>::__max; constexpr explicit - __semaphore_base(__count_type __count) noexcept + __semaphore_impl(__count_type __count) noexcept : _M_counter(__count) { } - __semaphore_base(const __semaphore_base&) = delete; - __semaphore_base& operator=(const __semaphore_base&) = delete; + __semaphore_impl(const __semaphore_impl&) = delete; + __semaphore_impl& operator=(const __semaphore_impl&) = delete; - static _GLIBCXX_ALWAYS_INLINE __count_type - _S_get_current(__count_type* __counter) noexcept + // Load the current counter value. + _GLIBCXX_ALWAYS_INLINE __count_type + _M_get_current() const noexcept + { return __atomic_impl::load(&_M_counter, memory_order::acquire); } + + // Try to acquire the semaphore (i.e. decrement the counter). + // Returns false if the current counter is zero, or if another thread + // changes the value first. In the latter case, __cur is set to the new + // value. + _GLIBCXX_ALWAYS_INLINE bool + _M_do_try_acquire(__count_type& __cur) noexcept + { + if (__cur == 0) + return false; // Cannot decrement when it's already zero. + + return __atomic_impl::compare_exchange_strong(&_M_counter, + __cur, __cur - 1, + memory_order::acquire, + memory_order::relaxed); + } + + // Keep trying to acquire the semaphore in a loop until it succeeds. + void + _M_acquire() noexcept + { + auto __vfn = [this]{ return _M_get_current(); }; + _Available __is_available{__vfn()}; + while (!_M_do_try_acquire(__is_available._M_val)) + if (!__is_available()) + std::__atomic_wait_address(&_M_counter, __is_available, __vfn, true); + } + + // Try to acquire the semaphore, retrying a small number of times + // in case of contention. + bool + _M_try_acquire() noexcept + { + // The fastest implementation of this function is just _M_do_try_acquire + // but that can fail under contention even when _M_count > 0. + // Using _M_try_acquire_for(0ns) will retry a few times in a loop. + return _M_try_acquire_for(__detail::__wait_clock_t::duration{}); + } + + template<typename _Clock, typename _Duration> + bool + _M_try_acquire_until(const chrono::time_point<_Clock, _Duration>& __atime) noexcept + { + auto __vfn = [this]{ return _M_get_current(); }; + _Available __is_available{__vfn()}; + while (!_M_do_try_acquire(__is_available._M_val)) + if (!__is_available()) + if (!std::__atomic_wait_address_until(&_M_counter, __is_available, + __vfn, __atime, true)) + return false; // timed out + return true; + } + + template<typename _Rep, typename _Period> + bool + _M_try_acquire_for(const chrono::duration<_Rep, _Period>& __rtime) noexcept + { + auto __vfn = [this]{ return _M_get_current(); }; + _Available __is_available{__vfn()}; + while (!_M_do_try_acquire(__is_available._M_val)) + if (!__is_available()) + if (!std::__atomic_wait_address_for(&_M_counter, __is_available, + __vfn, __rtime, true)) + return false; // timed out + return true; + } + + _GLIBCXX_ALWAYS_INLINE ptrdiff_t + _M_release(ptrdiff_t __update) noexcept { - return __atomic_impl::load(__counter, memory_order::acquire); + auto __old = __atomic_impl::fetch_add(&_M_counter, __update, + memory_order::release); + if (__old == 0 && __update > 0) + __atomic_notify_address(&_M_counter, true, true); + return __old; + } + + private: + struct _Available + { + __count_type _M_val; // Cache of the last value loaded from _M_counter. + + // Returns true if the cached value is non-zero and so it should be + // possible to acquire the semaphore. + bool operator()() const noexcept { return _M_val > 0; } + + // Argument should be the latest value of the counter. + // Returns true (and caches the value) if it's non-zero, meaning it + // should be possible to acquire the semaphore. Returns false otherwise. + bool operator()(__count_type __cur) noexcept + { + if (__cur == 0) + return false; + _M_val = __cur; + return true; + } + }; + + alignas(__atomic_ref<__count_type>::required_alignment) + __count_type _M_counter; + }; + + // Optimized specialization using __platform_wait (if available) + template<bool _Binary> + struct __platform_semaphore_impl + { + using __count_type = __detail::__platform_wait_t; + + static constexpr ptrdiff_t _S_max + = _Binary ? 1 : __gnu_cxx::__int_traits<__count_type>::__max; + + constexpr explicit + __platform_semaphore_impl(__count_type __count) noexcept + : _M_counter(__count) + { } + + __platform_semaphore_impl(__platform_semaphore_impl&) = delete; + __platform_semaphore_impl& operator=(const __platform_semaphore_impl&) = delete; + + // Load the current counter value. + _GLIBCXX_ALWAYS_INLINE __count_type + _M_get_current() const noexcept + { + if constexpr (_Binary) + return 1; // Not necessarily true, but optimistically assume it is. + else + return __atomic_impl::load(&_M_counter, memory_order::acquire); } - static _GLIBCXX_ALWAYS_INLINE bool - _S_do_try_acquire(__count_type* __counter, __count_type __old) noexcept + // Try to acquire the semaphore (i.e. decrement the counter). + // Returns false if the current counter is zero, or if another thread + // changes the value first. In the latter case, __cur is set to the new + // value. + _GLIBCXX_ALWAYS_INLINE bool + _M_do_try_acquire(__count_type& __cur) noexcept { - if (__old == 0) - return false; + if (__cur == 0) + return false; // Cannot decrement when it's already zero. - return __atomic_impl::compare_exchange_strong(__counter, - __old, __old - 1, + return __atomic_impl::compare_exchange_strong(&_M_counter, + __cur, __cur - 1, memory_order::acquire, memory_order::relaxed); } - _GLIBCXX_ALWAYS_INLINE void + // Keep trying to acquire the semaphore in a loop until it succeeds. + void _M_acquire() noexcept { - auto const __vfn = [this]{ return _S_get_current(&this->_M_counter); }; - auto const __pred = [this](__count_type __cur) { - return _S_do_try_acquire(&this->_M_counter, __cur); - }; - std::__atomic_wait_address(&_M_counter, __pred, __vfn, true); + auto __val = _M_get_current(); + while (!_M_do_try_acquire(__val)) + if (__val == 0) + { + std::__atomic_wait_address_v(&_M_counter, __val, __ATOMIC_ACQUIRE, + true); + __val = _M_get_current(); + } } + // Try to acquire the semaphore. bool _M_try_acquire() noexcept { - auto const __vfn = [this]{ return _S_get_current(&this->_M_counter); }; - auto const __pred = [this](__count_type __cur) { - return _S_do_try_acquire(&this->_M_counter, __cur); - }; - using __detail::__wait_clock_t; - return std::__atomic_wait_address_for(&_M_counter, __pred, __vfn, - __wait_clock_t::duration(), - true); + if constexpr (_Binary) + { + __count_type __val = 1; + // Do not expect much contention on binary semaphore, only try once. + return _M_do_try_acquire(__val); + } + else + // Fastest implementation of this function is just _M_do_try_acquire + // but that can fail under contention even when _M_count > 0. + // Using _M_try_acquire_for(0ns) will retry a few times in a loop. + return _M_try_acquire_for(__detail::__wait_clock_t::duration{}); } template<typename _Clock, typename _Duration> - _GLIBCXX_ALWAYS_INLINE bool + bool _M_try_acquire_until(const chrono::time_point<_Clock, _Duration>& __atime) noexcept { - auto const __vfn = [this]{ return _S_get_current(&this->_M_counter); }; - auto const __pred = [this](__count_type __cur) { - return _S_do_try_acquire(&this->_M_counter, __cur); - }; - return std::__atomic_wait_address_until(&_M_counter, __pred, __vfn, - __atime, true); + auto __val = _M_get_current(); + while (!_M_do_try_acquire(__val)) + if (__val == 0) + { + if (!std::__atomic_wait_address_until_v(&_M_counter, 0, + __ATOMIC_ACQUIRE, + __atime, true)) + return false; // timed out + __val = _M_get_current(); + } + return true; } template<typename _Rep, typename _Period> - _GLIBCXX_ALWAYS_INLINE bool + bool _M_try_acquire_for(const chrono::duration<_Rep, _Period>& __rtime) noexcept { - auto const __vfn = [this]{ return _S_get_current(&this->_M_counter); }; - auto const __pred = [this](__count_type __cur) { - return _S_do_try_acquire(&this->_M_counter, __cur); - }; - return std::__atomic_wait_address_for(&_M_counter, __pred, __vfn, - __rtime, true); + auto __val = _M_get_current(); + while (!_M_do_try_acquire(__val)) + if (__val == 0) + { + if (!std::__atomic_wait_address_for_v(&_M_counter, 0, + __ATOMIC_ACQUIRE, + __rtime, true)) + return false; // timed out + __val = _M_get_current(); + } + return true; } _GLIBCXX_ALWAYS_INLINE ptrdiff_t @@ -139,15 +285,26 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION return __old; } - private: - alignas(_Platform_wait ? __detail::__platform_wait_alignment - : __alignof__(__count_type)) - __count_type _M_counter; + protected: + alignas(__detail::__platform_wait_alignment) __count_type _M_counter; }; template<ptrdiff_t _Max> - using __semaphore_impl - = __semaphore_base<(_Max <= __semaphore_base<true>::_S_max)>; + using _Select_semaphore_impl = typename decltype([] + { + using namespace __detail; + if constexpr (__platform_wait_uses_type<__platform_wait_t>) + { + if constexpr (_Max <= 1) + return type_identity<__platform_semaphore_impl<true>>{}; + else if constexpr (_Max <= __platform_semaphore_impl<false>::_S_max) + return type_identity<__platform_semaphore_impl<false>>{}; + else + return type_identity<__semaphore_impl>{}; + } + else + return type_identity<__semaphore_impl>{}; + }())::type; _GLIBCXX_END_NAMESPACE_VERSION } // namespace std diff --git a/libstdc++-v3/include/bits/stl_vector.h b/libstdc++-v3/include/bits/stl_vector.h index 5c0c227..f2c1bce 100644 --- a/libstdc++-v3/include/bits/stl_vector.h +++ b/libstdc++-v3/include/bits/stl_vector.h @@ -372,8 +372,10 @@ _GLIBCXX_BEGIN_NAMESPACE_CONTAINER _GLIBCXX20_CONSTEXPR ~_Vector_base() _GLIBCXX_NOEXCEPT { - _M_deallocate(_M_impl._M_start, - _M_impl._M_end_of_storage - _M_impl._M_start); + ptrdiff_t __n = _M_impl._M_end_of_storage - _M_impl._M_start; + if (__n < 0) + __builtin_unreachable(); + _M_deallocate(_M_impl._M_start, size_t(__n)); } public: diff --git a/libstdc++-v3/include/bits/vector.tcc b/libstdc++-v3/include/bits/vector.tcc index 801d9f0..70ead1d 100644 --- a/libstdc++-v3/include/bits/vector.tcc +++ b/libstdc++-v3/include/bits/vector.tcc @@ -576,7 +576,7 @@ _GLIBCXX_BEGIN_NAMESPACE_CONTAINER __builtin_unreachable(); pointer __old_start = this->_M_impl._M_start; pointer __old_finish = this->_M_impl._M_finish; - const size_type __elems = end() - begin(); + const size_type __elems = size(); pointer __new_start(this->_M_allocate(__len)); pointer __new_finish(__new_start); diff --git a/libstdc++-v3/include/bits/version.def b/libstdc++-v3/include/bits/version.def index 5efe4d1..9ab22cc 100644 --- a/libstdc++-v3/include/bits/version.def +++ b/libstdc++-v3/include/bits/version.def @@ -1661,6 +1661,14 @@ ftms = { }; ftms = { + name = ranges_starts_ends_with; + values = { + v = 202106; + cxxmin = 23; + }; +}; + +ftms = { name = constexpr_bitset; values = { v = 202202; diff --git a/libstdc++-v3/include/bits/version.h b/libstdc++-v3/include/bits/version.h index 5e905da..371a7ba 100644 --- a/libstdc++-v3/include/bits/version.h +++ b/libstdc++-v3/include/bits/version.h @@ -1848,6 +1848,16 @@ #endif /* !defined(__cpp_lib_ranges_find_last) && defined(__glibcxx_want_ranges_find_last) */ #undef __glibcxx_want_ranges_find_last +#if !defined(__cpp_lib_ranges_starts_ends_with) +# if (__cplusplus >= 202100L) +# define __glibcxx_ranges_starts_ends_with 202106L +# if defined(__glibcxx_want_all) || defined(__glibcxx_want_ranges_starts_ends_with) +# define __cpp_lib_ranges_starts_ends_with 202106L +# endif +# endif +#endif /* !defined(__cpp_lib_ranges_starts_ends_with) && defined(__glibcxx_want_ranges_starts_ends_with) */ +#undef __glibcxx_want_ranges_starts_ends_with + #if !defined(__cpp_lib_constexpr_bitset) # if (__cplusplus >= 202100L) && _GLIBCXX_HOSTED && (__cpp_constexpr_dynamic_alloc) # define __glibcxx_constexpr_bitset 202202L diff --git a/libstdc++-v3/include/std/algorithm b/libstdc++-v3/include/std/algorithm index 321a5e2..1563cdf 100644 --- a/libstdc++-v3/include/std/algorithm +++ b/libstdc++-v3/include/std/algorithm @@ -74,6 +74,7 @@ #define __glibcxx_want_ranges_contains #define __glibcxx_want_ranges_find_last #define __glibcxx_want_ranges_fold +#define __glibcxx_want_ranges_starts_ends_with #define __glibcxx_want_robust_nonmodifying_seq_ops #define __glibcxx_want_sample #define __glibcxx_want_shift diff --git a/libstdc++-v3/include/std/bit b/libstdc++-v3/include/std/bit index 5187c96..fd75edf 100644 --- a/libstdc++-v3/include/std/bit +++ b/libstdc++-v3/include/std/bit @@ -166,7 +166,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION // Variant for power of two _Nd which the compiler can // easily pattern match. constexpr unsigned __uNd = _Nd; - const unsigned __r = __s; + const auto __r = static_cast<unsigned>(__s); return (__x << (__r % __uNd)) | (__x >> ((-__r) % __uNd)); } const int __r = __s % _Nd; @@ -188,7 +188,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION // Variant for power of two _Nd which the compiler can // easily pattern match. constexpr unsigned __uNd = _Nd; - const unsigned __r = __s; + const auto __r = static_cast<unsigned>(__s); return (__x >> (__r % __uNd)) | (__x << ((-__r) % __uNd)); } const int __r = __s % _Nd; diff --git a/libstdc++-v3/include/std/format b/libstdc++-v3/include/std/format index b4929d5..ec76ab0 100644 --- a/libstdc++-v3/include/std/format +++ b/libstdc++-v3/include/std/format @@ -2398,9 +2398,16 @@ namespace __format const size_t __r = __str.size() - __e; // Length of remainder. auto __overwrite = [&](_CharT* __p, size_t) { // Apply grouping to the digits before the radix or exponent. - auto __end = std::__add_grouping(__p, __np.thousands_sep(), + int __off = 0; + if (auto __c = __str.front(); __c == '-' || __c == '+' || __c == ' ') + { + *__p = __c; + __off = 1; + } + auto __end = std::__add_grouping(__p + __off, __np.thousands_sep(), __grp.data(), __grp.size(), - __str.data(), __str.data() + __e); + __str.data() + __off, + __str.data() + __e); if (__r) // If there's a fractional part or exponent { if (__d != __str.npos) diff --git a/libstdc++-v3/include/std/semaphore b/libstdc++-v3/include/std/semaphore index ca1bffe..8f49188 100644 --- a/libstdc++-v3/include/std/semaphore +++ b/libstdc++-v3/include/std/semaphore @@ -45,13 +45,12 @@ namespace std _GLIBCXX_VISIBILITY(default) { _GLIBCXX_BEGIN_NAMESPACE_VERSION - template<ptrdiff_t __least_max_value = __semaphore_base<true>::_S_max> + template<ptrdiff_t __least_max_value = _Select_semaphore_impl<2>::_S_max> class counting_semaphore { static_assert(__least_max_value >= 0); - using _Impl = __semaphore_impl<__least_max_value>; - _Impl _M_sem; + _Select_semaphore_impl<__least_max_value> _M_sem; public: constexpr explicit diff --git a/libstdc++-v3/include/std/stop_token b/libstdc++-v3/include/std/stop_token index 1225b3a..775ec6a 100644 --- a/libstdc++-v3/include/std/stop_token +++ b/libstdc++-v3/include/std/stop_token @@ -34,8 +34,7 @@ #define __glibcxx_want_jthread #include <bits/version.h> -#if __cplusplus > 201703L - +#ifdef __glibcxx_jthread // C++ >= 20 #include <atomic> #include <bits/std_thread.h> @@ -650,6 +649,6 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION stop_callback(stop_token, _Callback) -> stop_callback<_Callback>; _GLIBCXX_END_NAMESPACE_VERSION -} // namespace -#endif // __cplusplus > 201703L +} // namespace std +#endif // __glibcxx_jthread #endif // _GLIBCXX_STOP_TOKEN diff --git a/libstdc++-v3/include/std/type_traits b/libstdc++-v3/include/std/type_traits index 6bf355d..c8907fe 100644 --- a/libstdc++-v3/include/std/type_traits +++ b/libstdc++-v3/include/std/type_traits @@ -1039,6 +1039,13 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION // Destructible and constructible type properties. +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_destructible) + /// is_destructible + template<typename _Tp> + struct is_destructible + : public __bool_constant<__is_destructible(_Tp)> + { }; +#else // In N3290 is_destructible does not say anything about function // types and abstract types, see LWG 2049. This implementation // describes function types as non-destructible and all complete @@ -1090,7 +1097,15 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION static_assert(std::__is_complete_or_unbounded(__type_identity<_Tp>{}), "template argument must be a complete class or an unbounded array"); }; +#endif +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_nothrow_destructible) + /// is_nothrow_destructible + template<typename _Tp> + struct is_nothrow_destructible + : public __bool_constant<__is_nothrow_destructible(_Tp)> + { }; +#else /// @cond undocumented // is_nothrow_destructible requires that is_destructible is @@ -1144,6 +1159,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION static_assert(std::__is_complete_or_unbounded(__type_identity<_Tp>{}), "template argument must be a complete class or an unbounded array"); }; +#endif /// @cond undocumented template<typename _Tp, typename... _Args> @@ -1451,6 +1467,13 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION "template argument must be a complete class or an unbounded array"); }; +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_trivially_destructible) + /// is_trivially_destructible + template<typename _Tp> + struct is_trivially_destructible + : public __bool_constant<__is_trivially_destructible(_Tp)> + { }; +#else /// is_trivially_destructible template<typename _Tp> struct is_trivially_destructible @@ -1460,7 +1483,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION static_assert(std::__is_complete_or_unbounded(__type_identity<_Tp>{}), "template argument must be a complete class or an unbounded array"); }; - +#endif /// has_virtual_destructor template<typename _Tp> @@ -3581,8 +3604,13 @@ template <typename _Tp> inline constexpr bool is_move_assignable_v = __is_assignable(__add_lval_ref_t<_Tp>, __add_rval_ref_t<_Tp>); +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_destructible) +template <typename _Tp> + inline constexpr bool is_destructible_v = __is_destructible(_Tp); +#else template <typename _Tp> inline constexpr bool is_destructible_v = is_destructible<_Tp>::value; +#endif template <typename _Tp, typename... _Args> inline constexpr bool is_trivially_constructible_v @@ -3609,7 +3637,11 @@ template <typename _Tp> = __is_trivially_assignable(__add_lval_ref_t<_Tp>, __add_rval_ref_t<_Tp>); -#if __cpp_concepts +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_trivially_destructible) +template <typename _Tp> + inline constexpr bool is_trivially_destructible_v + = __is_trivially_destructible(_Tp); +#elif __cpp_concepts template <typename _Tp> inline constexpr bool is_trivially_destructible_v = false; @@ -3654,9 +3686,15 @@ template <typename _Tp> inline constexpr bool is_nothrow_move_assignable_v = __is_nothrow_assignable(__add_lval_ref_t<_Tp>, __add_rval_ref_t<_Tp>); +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_nothrow_destructible) +template <typename _Tp> + inline constexpr bool is_nothrow_destructible_v + = __is_nothrow_destructible(_Tp); +#else template <typename _Tp> inline constexpr bool is_nothrow_destructible_v = is_nothrow_destructible<_Tp>::value; +#endif template <typename _Tp> inline constexpr bool has_virtual_destructor_v diff --git a/libstdc++-v3/src/c++20/atomic.cc b/libstdc++-v3/src/c++20/atomic.cc index a3ec92a..4120e1a 100644 --- a/libstdc++-v3/src/c++20/atomic.cc +++ b/libstdc++-v3/src/c++20/atomic.cc @@ -397,17 +397,18 @@ __cond_wait_until(__condvar& __cv, mutex& __mx, } #endif // ! HAVE_PLATFORM_TIMED_WAIT -// Like __spin_impl, always returns _M_has_val == true. +// Unlike __spin_impl, does not always return _M_has_val == true. +// If the deadline has already passed then no fresh value is loaded. __wait_result_type __spin_until_impl(const __platform_wait_t* __addr, const __wait_args_base& __args, const __wait_clock_t::time_point& __deadline) { - auto __t0 = __wait_clock_t::now(); using namespace literals::chrono_literals; - __platform_wait_t __val{}; - auto __now = __wait_clock_t::now(); + __wait_result_type __res{}; + auto __t0 = __wait_clock_t::now(); + auto __now = __t0; for (; __now < __deadline; __now = __wait_clock_t::now()) { auto __elapsed = __now - __t0; @@ -422,16 +423,21 @@ __spin_until_impl(const __platform_wait_t* __addr, __thread_yield(); else { - auto __res = __detail::__spin_impl(__addr, __args); + __res = __detail::__spin_impl(__addr, __args); if (!__res._M_timeout) return __res; } - __atomic_load(__addr, &__val, __args._M_order); - if (__val != __args._M_old) - return { ._M_val = __val, ._M_has_val = true, ._M_timeout = false }; + __atomic_load(__addr, &__res._M_val, __args._M_order); + __res._M_has_val = true; + if (__res._M_val != __args._M_old) + { + __res._M_timeout = false; + return __res; + } } - return { ._M_val = __val, ._M_has_val = true, ._M_timeout = true }; + __res._M_timeout = true; + return __res; } } // namespace diff --git a/libstdc++-v3/src/c++23/std.cc.in b/libstdc++-v3/src/c++23/std.cc.in index ba46853..4cd3e52 100644 --- a/libstdc++-v3/src/c++23/std.cc.in +++ b/libstdc++-v3/src/c++23/std.cc.in @@ -507,11 +507,14 @@ export namespace std using ranges::find_last_if; using ranges::find_last_if_not; #endif +#if __cpp_lib_ranges_starts_ends_with + using ranges::starts_with; + using ranges::ends_with; +#endif } } // 22.7.2 <any> -#if __cpp_lib_any export namespace std { using std::any; @@ -520,7 +523,6 @@ export namespace std using std::make_any; using std::swap; } -#endif // 24.3.2 <array> export namespace std @@ -698,7 +700,6 @@ export namespace std } // 29.2 <chrono> -#if __cpp_lib_chrono export namespace std { namespace chrono @@ -852,7 +853,6 @@ export namespace std::inline literals::inline chrono_literals export namespace std::chrono { using namespace literals::chrono_literals; } -#endif // __cpp_lib_chrono // <codecvt>: deprecated C++17, removed C++26 export namespace std @@ -864,7 +864,6 @@ export namespace std } // 17.11.1 <compare> -#if __cpp_lib_three_way_comparison export namespace std { using std::common_comparison_category; @@ -890,7 +889,6 @@ export namespace std using std::strong_order; using std::weak_order; } -#endif // __cpp_lib_three_way_comparison // 28.4 <complex> export namespace std @@ -944,7 +942,6 @@ export namespace std::inline literals::inline complex_literals } // 18 <concepts> -#if __cpp_lib_concepts export namespace std { using std::assignable_from; @@ -983,7 +980,6 @@ export namespace std using std::totally_ordered; using std::totally_ordered_with; } -#endif // 33.7 <condition_variable> export namespace std @@ -1960,6 +1956,14 @@ export namespace std using std::out_ptr; using std::inout_ptr; #endif +#if __cpp_lib_indirect + using std::indirect; + namespace pmr { using std::pmr::indirect; } +#endif +#if __cpp_lib_polymorphic + using std::polymorphic; + namespace pmr { using std::pmr::polymorphic; } +#endif } // 20.4 <memory_resource> diff --git a/libstdc++-v3/testsuite/20_util/system_clock/99832.cc b/libstdc++-v3/testsuite/20_util/system_clock/99832.cc new file mode 100644 index 0000000..693d4d6 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/system_clock/99832.cc @@ -0,0 +1,14 @@ +// { dg-options "-O0 -g0" } +// { dg-do compile { target c++20 } } +// { dg-final { scan-assembler-not "system_clock9to_time_t" } } + +// Bug libstdc++/99832 +// std::chrono::system_clock::to_time_t needs ABI tag for 32-bit time_t + +#include <chrono> + +std::time_t +test_pr99832(std::chrono::system_clock::time_point t) +{ + return std::chrono::system_clock::to_time_t(t); +} diff --git a/libstdc++-v3/testsuite/25_algorithms/ends_with/1.cc b/libstdc++-v3/testsuite/25_algorithms/ends_with/1.cc new file mode 100644 index 0000000..612c27a --- /dev/null +++ b/libstdc++-v3/testsuite/25_algorithms/ends_with/1.cc @@ -0,0 +1,165 @@ +// { dg-do run { target c++23 } } + +#include <algorithm> +#include <ranges> + +#include <testsuite_hooks.h> +#include <testsuite_iterators.h> + +namespace ranges = std::ranges; + +template<typename Range1, typename Range2> +void +test01() +{ + int n[] = {1,2,3,4,5,6,7,8,9,10}; + + Range1 haystack(n, n+10); + Range2 needle(n+7, n+10); + VERIFY( ranges::ends_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n, n+10); + VERIFY( ranges::ends_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( !ranges::ends_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack, needle, + [](int n, int m) { return std::abs(n - m) <= 1; }) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack, needle, + ranges::equal_to{}, + [](int n) { return n - 1; }) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack, needle, + ranges::equal_to{}, + std::identity{}, + [](int n) { return n + 1; }) ); + + haystack = Range1(n, n+5); + needle = Range2(n, n+10); + VERIFY( !ranges::ends_with(haystack, needle) ); +} + +template<typename Range1, typename Range2> +void +test02() +{ + int n[] = {1,2,3,4,5,6,7,8,9,10}; + + Range1 haystack(n, n+10); + Range2 needle(n+7, n+10); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n, n+10); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( !ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + [](int n, int m) { return std::abs(n - m) <= 1; }) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + ranges::equal_to{}, + [](int n) { return n - 1; }) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + ranges::equal_to{}, + std::identity{}, + [](int n) { return n + 1; }) ); + + haystack = Range1(n, n+5); + needle = Range2(n, n+10); + VERIFY( !ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n, n+5); + needle = Range2(n+10, n+10); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); +} + +void +test03() +{ + auto haystack = std::views::iota(0, 10); + auto needle = std::views::iota(5, 10); + +#if __SIZEOF_INT128__ + auto haystack_ict = std::views::iota(__int128(0), __int128(10)); + auto needle_ict = std::views::iota(__int128(5), __int128(10)); +#else + auto haystack_ict = std::views::iota(0ll, 10ll); + auto needle_ict = std::views::iota(5ll, 10ll); +#endif + + VERIFY( ranges::ends_with(haystack, needle_ict) ); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle_ict.begin(), needle_ict.end()) ); + + VERIFY( ranges::ends_with(haystack_ict, needle) ); + VERIFY( ranges::ends_with(haystack_ict.begin(), haystack_ict.end(), + needle.begin(), needle.end()) ); + + VERIFY( ranges::ends_with(haystack_ict, needle_ict) ); + VERIFY( ranges::ends_with(haystack_ict.begin(), haystack_ict.end(), + needle_ict.begin(), needle_ict.end()) ); +} + +int +main() +{ + using namespace __gnu_test; + using forward = test_forward_range<int>; + using bidirectional_common = bidirectional_container<int>; + using input_sized = test_input_sized_range<int>; + using input_sized_sent = test_sized_range_sized_sent<int, input_iterator_wrapper>; + using random_access = test_random_access_range<int>; + using random_access_sized = test_random_access_sized_range<int>; + using random_access_sized_sent = test_sized_range_sized_sent<int, random_access_iterator_wrapper>; + + test01<forward, forward>(); + test01<random_access, random_access>(); + test02<forward, forward>(); + test02<random_access, random_access>(); + + test01<bidirectional_common, bidirectional_common>(); + test02<bidirectional_common, bidirectional_common>(); + test01<bidirectional_common, forward>(); + test02<bidirectional_common, forward>(); + + test01<input_sized, input_sized>(); + test01<random_access_sized, random_access_sized>(); + // test02<input_sized, input_sized>(); constraint violation + test02<random_access_sized, random_access_sized>(); + + test01<input_sized_sent, input_sized_sent>(); + test01<random_access_sized_sent, random_access_sized_sent>(); + test02<input_sized_sent, input_sized_sent>(); + test02<random_access_sized_sent, random_access_sized_sent>(); + + test03(); +} diff --git a/libstdc++-v3/testsuite/25_algorithms/starts_with/1.cc b/libstdc++-v3/testsuite/25_algorithms/starts_with/1.cc new file mode 100644 index 0000000..0c288d8 --- /dev/null +++ b/libstdc++-v3/testsuite/25_algorithms/starts_with/1.cc @@ -0,0 +1,158 @@ +// { dg-do run { target c++23 } } + +#include <algorithm> +#include <ranges> + +#include <testsuite_hooks.h> +#include <testsuite_iterators.h> + +namespace ranges = std::ranges; + +template<typename Range1, typename Range2> +void +test01() +{ + int n[] = {1,2,3,4,5,6,7,8,9,10}; + + Range1 haystack(n, n+10); + Range2 needle(n, n+3); + VERIFY( ranges::starts_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n, n+10); + VERIFY( ranges::starts_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( !ranges::starts_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack, needle, + [](int n, int m) { return std::abs(n - m) <= 1; }) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack, needle, + ranges::equal_to{}, + [](int n) { return n + 1; }) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack, needle, + ranges::equal_to{}, + std::identity{}, + [](int n) { return n - 1; }) ); + + haystack = Range1(n, n+5); + needle = Range2(n, n+10); + VERIFY( !ranges::starts_with(haystack, needle) ); + + haystack = Range1(n, n+5); + needle = Range2(n+10, n+10); + VERIFY( ranges::starts_with(haystack, needle) ); +} + +template<typename Range1, typename Range2> +void +test02() +{ + int n[] = {1,2,3,4,5,6,7,8,9,10}; + + Range1 haystack(n, n+10); + Range2 needle(n, n+3); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n, n+10); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( !ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + [](int n, int m) { return std::abs(n - m) <= 1; }) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + ranges::equal_to{}, + [](int n) { return n + 1; }) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + ranges::equal_to{}, + std::identity{}, + [](int n) { return n - 1; }) ); + + haystack = Range1(n, n+5); + needle = Range2(n, n+10); + VERIFY( !ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); +} + +void +test03() +{ + auto haystack = std::views::iota(0, 10); + auto needle = std::views::iota(0, 5); + +#if __SIZEOF_INT128__ + auto haystack_ict = std::views::iota(__int128(0), __int128(10)); + auto needle_ict = std::views::iota(__int128(0), __int128(5)); +#else + auto haystack_ict = std::views::iota(0ll, 10ll); + auto needle_ict = std::views::iota(0ll, 5ll); +#endif + + VERIFY( ranges::starts_with(haystack, needle_ict) ); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle_ict.begin(), needle_ict.end()) ); + + VERIFY( ranges::starts_with(haystack_ict, needle) ); + VERIFY( ranges::starts_with(haystack_ict.begin(), haystack_ict.end(), + needle.begin(), needle.end()) ); + + VERIFY( ranges::starts_with(haystack_ict, needle_ict) ); + VERIFY( ranges::starts_with(haystack_ict.begin(), haystack_ict.end(), + needle_ict.begin(), needle_ict.end()) ); +} + +int +main() +{ + using namespace __gnu_test; + using input = test_input_range<int>; + using input_sized = test_input_sized_range<int>; + using input_sized_sent = test_sized_range_sized_sent<int, input_iterator_wrapper>; + using random_access = test_random_access_range<int>; + using random_access_sized = test_random_access_sized_range<int>; + using random_access_sized_sent = test_sized_range_sized_sent<int, random_access_iterator_wrapper>; + + test01<input, input>(); + test01<random_access, random_access>(); + test02<input, input>(); + test02<random_access, random_access>(); + + test01<input_sized, input_sized>(); + test01<random_access_sized, random_access_sized>(); + test02<input_sized, input_sized>(); + test02<random_access_sized, random_access_sized>(); + + test01<input_sized_sent, input_sized_sent>(); + test01<random_access_sized_sent, random_access_sized_sent>(); + test02<input_sized_sent, input_sized_sent>(); + test02<random_access_sized_sent, random_access_sized_sent>(); + + test03(); +} diff --git a/libstdc++-v3/testsuite/30_threads/semaphore/104928-2.cc b/libstdc++-v3/testsuite/30_threads/semaphore/104928-2.cc new file mode 100644 index 0000000..7b90da8 --- /dev/null +++ b/libstdc++-v3/testsuite/30_threads/semaphore/104928-2.cc @@ -0,0 +1,101 @@ +// { dg-do run { target c++20 } } +// { dg-additional-options "-pthread" { target pthread } } +// { dg-require-gthreads "" } +// { dg-add-options libatomic } + +// Bug libstdc++/104928 - std::counting_semaphore on Linux can sleep forever + +#include <semaphore> +#include <thread> +#include <chrono> +#include <atomic> + +std::binary_semaphore t1(1); +std::binary_semaphore sem2(0); +std::atomic<int> room1 = 0; +int room2 = 0; + +std::atomic<bool> run{true}; + +enum class AcquireKind { Acquire, Try, TryFor }; + +template<std::ptrdiff_t N, AcquireKind Kind> +struct Morris +{ + using Semaphore = std::counting_semaphore<N>; + + Semaphore sem1{1}; + Semaphore sem2{0}; + unsigned counter = 0; + + void operator()() + { + while (run) + { + room1 += 1; + + acquire(sem1); + room2 += 1; + room1 -= 1; + if (room1 == 0) + sem2.release(); + else + sem1.release(); + + acquire(sem2); + room2 -= 1; + + // critical region + ++counter; + // end critical region + + if (room2 == 0) + sem1.release(); + else + sem2.release(); + } + } + + void acquire(Semaphore& sem) + { + using enum AcquireKind; + using namespace std::chrono; + if constexpr (Kind == Acquire) + sem.acquire(); + else if constexpr (Kind == Try) + while (!sem.try_acquire()) { } + else if constexpr (Kind == TryFor) + while (!sem.try_acquire_for(1h)) { } + } +}; + +template<std::ptrdiff_t N, AcquireKind Kind> +void +test_morris_kind() +{ + Morris<N, Kind> algo; + std::thread t1(std::ref(algo)); + std::thread t2(std::ref(algo)); + std::this_thread::sleep_for(std::chrono::seconds(2)); + run = false; + t1.join(); + t2.join(); +} + +template<std::ptrdiff_t N> +void +test_morris() +{ + test_morris_kind<N, AcquireKind::Acquire>(); + test_morris_kind<N, AcquireKind::Try>(); + test_morris_kind<N, AcquireKind::TryFor>(); +} + +int main() +{ + test_morris<1>(); // std::binary_semaphore + test_morris<1000>(); // std::counting_semaphore that can use futex +#if PTRDIFF_MAX > INT_MAX + // test_morris<PTRDIFF_MAX>(); // std::counting_semaphore that cannot use futex +#endif +} diff --git a/libstdc++-v3/testsuite/30_threads/semaphore/104928.cc b/libstdc++-v3/testsuite/30_threads/semaphore/104928.cc new file mode 100644 index 0000000..f360da9 --- /dev/null +++ b/libstdc++-v3/testsuite/30_threads/semaphore/104928.cc @@ -0,0 +1,70 @@ +// { dg-do run { target c++20 } } +// { dg-additional-options "-pthread" { target pthread } } +// { dg-require-gthreads "" } +// { dg-add-options libatomic } +// { dg-options "-DSIMULATOR_TEST" { target simulator } } + +// Bug libstdc++/104928 - std::counting_semaphore on Linux can sleep forever + +#include <semaphore> +#include <thread> +#include <chrono> +#include <climits> + +#ifdef SIMULATOR_TEST +const int loop_count = 100; +const int thread_count = 6; +#else +const int loop_count = 1000000; +const int thread_count = 20; +#endif + +template<std::ptrdiff_t N, typename Acquire> +void +test_acquire(Acquire acq_func) +{ + std::counting_semaphore<N * loop_count> s{0}; + std::thread threads[thread_count]; + for (int i = 0; i < thread_count; i += 2) { + threads[i] = std::thread([&s, &acq_func]() { + for (int i = 0; i < loop_count; ++i) + acq_func(s); + }); + threads[i+1] = std::thread([&s]() { + for (int i = 0; i < loop_count; ++i) + s.release(); + }); + } + for (auto& t : threads) + t.join(); +} + +template<typename Acquire> +void +test_all(Acquire f) +{ + const int max = INT_MAX / loop_count; + test_acquire<max>(f); // can use futex +#if PTRDIFF_MAX > INT_MAX + test_acquire<max * 10>(f); // cannot use futex +#endif +} + +int main() +{ + test_all([](auto& sem) { sem.acquire(); }); + + test_all([](auto& sem) { while (!sem.try_acquire()) { } }); + + using namespace std::chrono; + + test_all([](auto& sem) { while (!sem.try_acquire_for(1h)) { } }); + + auto try_acquire_until = [](auto& sem, auto time) { + while (!sem.try_acquire_until(time + 1h)) + { } + }; + test_all([&](auto& sem) { try_acquire_until(sem, system_clock::now()); }); + test_all([&](auto& sem) { try_acquire_until(sem, steady_clock::now()); }); + test_all([&](auto& sem) { try_acquire_until(sem, utc_clock::now()); }); +} diff --git a/libstdc++-v3/testsuite/std/format/functions/format.cc b/libstdc++-v3/testsuite/std/format/functions/format.cc index e4adf3a..d342114 100644 --- a/libstdc++-v3/testsuite/std/format/functions/format.cc +++ b/libstdc++-v3/testsuite/std/format/functions/format.cc @@ -261,6 +261,16 @@ test_locale() s = std::format(eloc, "{0:Le} {0:Lf} {0:Lg}", -nan); VERIFY( s == "-nan -nan -nan" ); + // PR libstdc++/120548 format confuses a negative sign for a thousands digit + s = std::format(bloc, "{:L}", -123.45); + VERIFY( s == "-123.45" ); + s = std::format(bloc, "{:-L}", -876543.21); + VERIFY( s == "-876,543.21" ); + s = std::format(bloc, "{:+L}", 333.22); + VERIFY( s == "+333.22" ); + s = std::format(bloc, "{: L}", 999.44); + VERIFY( s == " 999.44" ); + // Restore std::locale::global(cloc); } diff --git a/libstdc++-v3/testsuite/std/time/format/empty_spec.cc b/libstdc++-v3/testsuite/std/time/format/empty_spec.cc index 322faa1..99cbd74 100644 --- a/libstdc++-v3/testsuite/std/time/format/empty_spec.cc +++ b/libstdc++-v3/testsuite/std/time/format/empty_spec.cc @@ -1,7 +1,9 @@ // { dg-do run { target c++20 } } -// { dg-timeout-factor 2 } +// { dg-require-effective-target hosted } +// { dg-timeout-factor 5 } #include <chrono> +#include <ranges> #include <sstream> #include <testsuite_hooks.h> @@ -10,6 +12,46 @@ using namespace std::chrono; #define WIDEN_(C, S) ::std::__format::_Widen<C>(S, L##S) #define WIDEN(S) WIDEN_(_CharT, S) +template<typename CharT, typename T> +void +test_no_empty_spec() +{ + try + { + T t{}; + + if constexpr (std::is_same_v<CharT, char>) + (void)std::vformat("{}", std::make_format_args(t)); +#ifdef _GLIBCXX_USE_WCHAR_T + else + (void)std::vformat(L"{}", std::make_wformat_args(t)); +#endif // _GLIBCXX_USE_WCHAR_T + VERIFY(false); + } + catch (const std::format_error&) + { + VERIFY(true); + } +} + +template<typename T, typename _CharT> +void verify(const T& t, std::basic_string_view<_CharT> str) +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{}"), t); + VERIFY( res == str ); + + std::basic_stringstream<_CharT> os; + os << t; + res = std::move(os).str(); + VERIFY( res == str ); +} + +template<typename T, typename CharT> +void verify(const T& t, const CharT* str) +{ verify(t, std::basic_string_view<CharT>(str)); } + template<typename _CharT> void test_padding() @@ -35,18 +77,272 @@ test_padding() VERIFY( res == WIDEN("==16 is not a valid month==") ); } -template<typename T, typename _CharT> -void verify(const T& t, const _CharT* str) +template<typename Ret = void> +struct Rep +{ + using Return + = std::conditional_t<std::is_void_v<Ret>, Rep, Ret>; + + Rep(long v = 0) : val(v) {} + + operator long() const + { return val; } + + Return + operator+() const + { return val; } + + Rep + operator-() const + { return -val; } + + friend Rep + operator+(Rep lhs, Rep rhs) + { return lhs.val + rhs.val; } + + friend Rep + operator-(Rep lhs, Rep rhs) + { return lhs.val - rhs.val; } + + friend Rep + operator*(Rep lhs, Rep rhs) + { return lhs.val * rhs.val; } + + friend Rep + operator/(Rep lhs, Rep rhs) + { return lhs.val / rhs.val; } + + friend auto operator<=>(Rep, Rep) = default; + + template<typename _CharT> + friend std::basic_ostream<_CharT>& + operator<<(std::basic_ostream<_CharT>& os, const Rep& t) + { return os << t.val << WIDEN("[via <<]"); } + + long val; +}; + +template<typename Ret, typename Other> + requires std::is_integral_v<Other> +struct std::common_type<Rep<Ret>, Other> +{ + using type = Rep<Ret>; +}; + +template<typename Ret, typename Other> + requires std::is_integral_v<Other> +struct std::common_type<Other, Rep<Ret>> + : std::common_type<Rep<Ret>, Other> +{ }; + +template<typename Ret> +struct std::numeric_limits<Rep<Ret>> + : std::numeric_limits<long> +{ }; + +template<typename Ret, typename _CharT> +struct std::formatter<Rep<Ret>, _CharT> + : std::formatter<long, _CharT> +{ + template<typename Out> + typename std::basic_format_context<Out, _CharT>::iterator + format(const Rep<Ret>& t, std::basic_format_context<Out, _CharT>& ctx) const + { + constexpr std::basic_string_view<_CharT> suffix = WIDEN("[via format]"); + auto out = std::formatter<long, _CharT>::format(t.val, ctx); + return std::ranges::copy(suffix, out).out; + } +}; + +using deciseconds = duration<seconds::rep, std::deci>; + +template<typename _CharT> +void +test_duration() { std::basic_string<_CharT> res; - res = std::format(WIDEN("{}"), t); - VERIFY( res == str ); + const milliseconds di(40); + verify( di, WIDEN("40ms") ); + res = std::format(WIDEN("{:>6}"), di); + VERIFY( res == WIDEN(" 40ms") ); - std::basic_stringstream<_CharT> os; - os << t; - res = std::move(os).str(); - VERIFY( res == str ); + verify( -di, WIDEN("-40ms") ); + res = std::format(WIDEN("{:>6}"), -di); + VERIFY( res == WIDEN(" -40ms") ); + + const duration<double> df(11.22); + verify( df, WIDEN("11.22s") ); + res = std::format(WIDEN("{:=^12}"), df); + VERIFY( res == WIDEN("===11.22s===") ); + + verify( -df, WIDEN("-11.22s") ); + res = std::format(WIDEN("{:=^12}"), -df); + VERIFY( res == WIDEN("==-11.22s===") ); +} + +template<typename _CharT> +void +test_duration_cust() +{ + std::basic_string<_CharT> res; + const duration<char, std::ratio<1, 10>> charRep(123); + verify( charRep, WIDEN("123ds") ); + + // +asLong returns long, so formatted as long + const duration<Rep<long>> asLong(20); + verify( asLong, WIDEN("20s") ); + res = std::format(WIDEN("{:>6}"), asLong); + VERIFY( res == WIDEN(" 20s") ); + + verify( -asLong, WIDEN("-20s") ); + res = std::format(WIDEN("{:>6}"), -asLong); + VERIFY( res == WIDEN(" -20s") ); + + res = std::format(WIDEN("{:%Q}"), asLong); + VERIFY( res == WIDEN("20") ); + res = std::format(WIDEN("{:+<7%Q}"), asLong); + VERIFY( res == WIDEN("20+++++") ); + + // +asRep returns Rep<>, so formatted as Rep<> + const duration<Rep<>> asRep(10); + verify( asRep, WIDEN("10[via <<]s") ); + res = std::format(WIDEN("{:=^15}"), asRep); + VERIFY( res == WIDEN("==10[via <<]s==") ); + + verify( -asRep, WIDEN("-10[via <<]s") ); + res = std::format(WIDEN("{:=^15}"), -asRep); + VERIFY( res == WIDEN("=-10[via <<]s==") ); + + res = std::format(WIDEN("{:%Q}"), asRep); + VERIFY( res == WIDEN("10[via format]") ); + res = std::format(WIDEN("{:=^18%Q}"), asRep); + VERIFY( res == WIDEN("==10[via format]==") ); + + const duration<Rep<>, std::milli> milliRep(10); + verify( milliRep, WIDEN("10[via <<]ms") ); + res = std::format(WIDEN("{:=^15}"), milliRep); + VERIFY( res == WIDEN("=10[via <<]ms==") ); + + verify( -milliRep, WIDEN("-10[via <<]ms") ); + res = std::format(WIDEN("{:=^15}"), -milliRep); + VERIFY( res == WIDEN("=-10[via <<]ms=") ); + + res = std::format(WIDEN("{:%Q}"), milliRep); + VERIFY( res == WIDEN("10[via format]") ); + res = std::format(WIDEN("{:=^18%Q}"), milliRep); + VERIFY( res == WIDEN("==10[via format]==") ); +} + +template<typename Ratio, typename Rep, typename Period> +constexpr auto +hms(const duration<Rep, Period>& d) +{ + using Dur = duration<Rep, typename Ratio::period>; + return hh_mm_ss<Dur>(duration_cast<Dur>(d)); +} + +template<typename _CharT> +void +test_hh_mm_ss() +{ + auto dt = 22h + 24min + 54s + 111222333ns; + verify( hms<nanoseconds>(dt), + WIDEN("22:24:54.111222333") ); + verify( hms<microseconds>(dt), + WIDEN("22:24:54.111222") ); + verify( hms<milliseconds>(dt), + WIDEN("22:24:54.111") ); + verify( hms<deciseconds>(dt), + WIDEN("22:24:54.1") ); + verify( hms<seconds>(dt), + WIDEN("22:24:54") ); + verify( hms<minutes>(dt), + WIDEN("22:24:00") ); + verify( hms<hours>(dt), + WIDEN("22:00:00") ); + verify( hms<nanoseconds>(-dt), + WIDEN("-22:24:54.111222333") ); + verify( hms<microseconds>(-dt), + WIDEN("-22:24:54.111222") ); + verify( hms<milliseconds>(-dt), + WIDEN("-22:24:54.111") ); + verify( hms<deciseconds>(-dt), + WIDEN("-22:24:54.1") ); + verify( hms<seconds>(-dt), + WIDEN("-22:24:54") ); + verify( hms<minutes>(-dt), + WIDEN("-22:24:00") ); + verify( hms<hours>(-dt), + WIDEN("-22:00:00") ); + + verify( hms<nanoseconds>(-dt), + WIDEN("-22:24:54.111222333") ); + + dt += 300h; + verify( hms<nanoseconds>(dt), + WIDEN("322:24:54.111222333") ); + verify( hms<nanoseconds>(-dt), + WIDEN("-322:24:54.111222333") ); + + dt += 14000h; + verify( hms<nanoseconds>(dt), + WIDEN("14322:24:54.111222333") ); + verify( hms<nanoseconds>(-dt), + WIDEN("-14322:24:54.111222333") ); +} + +template<typename _CharT> +void +test_hh_mm_ss_cust() +{ + const duration<char, deciseconds::period> charRep(123); + verify( hms<deciseconds>(charRep), + WIDEN("00:00:12.3") ); + verify( hms<seconds>(charRep), + WIDEN("00:00:12") ); + + auto dt = 22h + 24min + 54s + 123ms; + // +plus returns long, so formatted as long + const duration<Rep<long>, std::milli> asLong(dt.count()); + verify( hms<milliseconds>(asLong), + WIDEN("22:24:54.123[via format]") ); + verify( hms<deciseconds>(asLong), + WIDEN("22:24:54.1[via format]") ); + verify( hms<seconds>(asLong), + WIDEN("22:24:54") ); + verify( hms<milliseconds>(-asLong), + WIDEN("-22:24:54.123[via format]") ); + verify( hms<deciseconds>(-asLong), + WIDEN("-22:24:54.1[via format]") ); + verify( hms<seconds>(-asLong), + WIDEN("-22:24:54") ); + + // +asRep returns Rep<>, so formatted as Rep<> + const duration<Rep<>, std::milli> asRep(dt.count()); + verify( hms<milliseconds>(asRep), + WIDEN("22:24:54.123[via format]") ); + verify( hms<deciseconds>(asRep), + WIDEN("22:24:54.1[via format]") ); + verify( hms<seconds>(asLong), + WIDEN("22:24:54") ); + verify( hms<milliseconds>(-asLong), + WIDEN("-22:24:54.123[via format]") ); + verify( hms<deciseconds>(-asLong), + WIDEN("-22:24:54.1[via format]") ); + verify( hms<seconds>(-asLong), + WIDEN("-22:24:54") ); +} + +template<typename CharT> +void +test_durations() +{ + test_duration<CharT>(); + test_duration_cust<CharT>(); + + test_hh_mm_ss<CharT>(); + test_hh_mm_ss_cust<CharT>(); } template<typename _CharT> @@ -196,19 +492,15 @@ test_year_month_day() verify( year(2024)/month(1)/30, WIDEN("2024-01-30") ); verify( year(-100)/month(14)/1, - // Should be -0100-14-01 - WIDEN("-100-14-01 is not a valid date") ); + WIDEN("-0100-14-01 is not a valid date") ); verify( year(2025)/month(11)/100, - // Should be 2025-11-100 ? - WIDEN("2025-11-99 is not a valid date") ); + WIDEN("2025-11-100 is not a valid date") ); verify( year(-32768)/month(2)/10, WIDEN("-32768-02-10 is not a valid date") ); verify( year(-32768)/month(212)/10, - // Should be 32768-212-10? - WIDEN("-32768-84-10 is not a valid date") ); + WIDEN("-32768-212-10 is not a valid date") ); verify( year(-32768)/month(2)/105, - // Should be 32768-02-99? - WIDEN("-32768-02-99 is not a valid date") ); + WIDEN("-32768-02-105 is not a valid date") ); verify( year(-32768)/month(14)/55, WIDEN("-32768-14-55 is not a valid date") ); } @@ -283,12 +575,276 @@ test_calendar() test_year_month_weekday_last<CharT>(); } +template<typename Clock, typename Dur, typename Dur2> +constexpr auto +wall_cast(const local_time<Dur2>& tp) +{ + using TP = time_point<Clock, std::common_type_t<Dur, days>>; + if constexpr (std::is_same_v<Clock, utc_clock> || std::is_same_v<Clock, file_clock>) + return clock_cast<Clock>(wall_cast<system_clock, Dur>(tp)); + else if constexpr (std::is_same_v<Clock, tai_clock>) + return TP(floor<Dur>(tp.time_since_epoch()) + days(4383)); + else if constexpr (std::is_same_v<Clock, gps_clock>) + return TP(floor<Dur>(tp.time_since_epoch()) - days(3657)); + else // system_clock, local_t + return time_point<Clock, Dur>(floor<Dur>(tp.time_since_epoch())); +} + +using decadays = duration<days::rep, std::ratio_multiply<std::deca, days::period>>; +using kilodays = duration<days::rep, std::ratio_multiply<std::kilo, days::period>>; + +template<typename _CharT, typename Clock> +void +test_time_point(bool daysAsTime) +{ + std::basic_string<_CharT> res; + + const auto lt = local_days(2024y/March/22) + 13h + 24min + 54s + 111222333ns; + auto strip_time = [daysAsTime](std::basic_string_view<_CharT> sv) + { return daysAsTime ? sv : sv.substr(0, 10); }; + + verify( wall_cast<Clock, nanoseconds>(lt), + WIDEN("2024-03-22 13:24:54.111222333") ); + verify( wall_cast<Clock, microseconds>(lt), + WIDEN("2024-03-22 13:24:54.111222") ); + verify( wall_cast<Clock, milliseconds>(lt), + WIDEN("2024-03-22 13:24:54.111") ); + verify( wall_cast<Clock, seconds>(lt), + WIDEN("2024-03-22 13:24:54") ); + verify( wall_cast<Clock, minutes>(lt), + WIDEN("2024-03-22 13:24:00") ); + verify( wall_cast<Clock, hours>(lt), + WIDEN("2024-03-22 13:00:00") ); + verify( wall_cast<Clock, days>(lt), + strip_time(WIDEN("2024-03-22 00:00:00")) ); + verify( wall_cast<Clock, decadays>(lt), + strip_time(WIDEN("2024-03-18 00:00:00")) ); + verify( wall_cast<Clock, kilodays>(lt), + strip_time(WIDEN("2022-01-08 00:00:00")) ); +} + +template<typename _CharT> +void +test_leap_second() +{ + std::basic_string<_CharT> res; + + const auto st = sys_days(2012y/June/30) + 23h + 59min + 59s + 111222333ns; + auto tp = clock_cast<utc_clock>(st); + tp += 1s; + + verify( floor<nanoseconds>(tp), + WIDEN("2012-06-30 23:59:60.111222333") ); + verify( floor<microseconds>(tp), + WIDEN("2012-06-30 23:59:60.111222") ); + verify( floor<milliseconds>(tp), + WIDEN("2012-06-30 23:59:60.111") ); + verify( floor<seconds>(tp), + WIDEN("2012-06-30 23:59:60") ); +} + +#if _GLIBCXX_USE_CXX11_ABI || !_GLIBCXX_USE_DUAL_ABI +template<typename Dur, typename Dur2> +auto +make_zoned(const sys_time<Dur2>& st, const time_zone* tz) +{ return zoned_time<Dur>(tz, floor<Dur>(st)); } + +template<typename _CharT> +void +test_zoned_time() +{ + const auto st = sys_days(2024y/March/22) + 13h + 24min + 54s + 111222333ns; + const time_zone* tz = locate_zone("Europe/Sofia"); + VERIFY( tz != nullptr ); + + verify( make_zoned<nanoseconds>(st, tz), + WIDEN("2024-03-22 15:24:54.111222333 EET") ); + verify( make_zoned<microseconds>(st, tz), + WIDEN("2024-03-22 15:24:54.111222 EET") ); + verify( make_zoned<milliseconds>(st, tz), + WIDEN("2024-03-22 15:24:54.111 EET") ); + verify( make_zoned<seconds>(st, tz), + WIDEN("2024-03-22 15:24:54 EET") ); + verify( make_zoned<minutes>(st, tz), + WIDEN("2024-03-22 15:24:00 EET") ); + verify( make_zoned<hours>(st, tz), + WIDEN("2024-03-22 15:00:00 EET") ); + verify( make_zoned<days>(st, tz), + WIDEN("2024-03-22 02:00:00 EET") ); + verify( make_zoned<decadays>(st, tz), + WIDEN("2024-03-18 02:00:00 EET") ); + verify( make_zoned<kilodays>(st, tz), + WIDEN("2022-01-08 02:00:00 EET") ); +} +#endif + +template<typename Dur, typename Dur2> +auto +local_fmt(const local_time<Dur2>& lt, std::string* zone) +{ return local_time_format(floor<Dur>(lt), zone); } + +template<typename _CharT> +void +test_local_time_format() +{ + std::basic_string<_CharT> res; + + std::string abbrev = "Zone"; + const auto lt = local_days(2024y/March/22) + 13h + 24min + 54s + 111222333ns; + + res = std::format(WIDEN("{}"), local_fmt<nanoseconds>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:54.111222333 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<microseconds>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:54.111222 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<milliseconds>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:54.111 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<seconds>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:54 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<minutes>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:00 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<hours>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:00:00 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<days>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 00:00:00 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<decadays>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-18 00:00:00 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<kilodays>(lt, &abbrev)); + VERIFY( res == WIDEN("2022-01-08 00:00:00 Zone") ); +} + +template<typename CharT> +void +test_time_points() +{ + test_time_point<CharT, local_t>(false); + test_time_point<CharT, system_clock>(false); + test_time_point<CharT, utc_clock>(true); + test_time_point<CharT, tai_clock>(true); + test_time_point<CharT, gps_clock>(true); + test_time_point<CharT, file_clock>(true); + test_leap_second<CharT>(); +#if _GLIBCXX_USE_CXX11_ABI || !_GLIBCXX_USE_DUAL_ABI + test_zoned_time<CharT>(); +#endif + test_local_time_format<CharT>(); + + test_no_empty_spec<CharT, sys_time<years>>(); + test_no_empty_spec<CharT, sys_time<duration<float>>>(); +} + +#if _GLIBCXX_USE_CXX11_ABI || !_GLIBCXX_USE_DUAL_ABI +template<typename _CharT> +void +test_sys_info() +{ + const sys_info si + { + sys_days(2024y/March/22) + 2h, + sys_days(2025y/April/11) + 23h + 15min + 10s, + 2h + 13min + 4s, + 15min, + "Zone" + }; + const std::basic_string_view<_CharT> txt + = WIDEN("[2024-03-22 02:00:00,2025-04-11 23:15:10,02:13:04,15min,Zone]"); + + verify( si, txt ); + + std::basic_string<_CharT> res; + std::basic_string_view<_CharT> sv; + + sv = res = std::format(WIDEN("{:65}"), si); + VERIFY( sv.ends_with(WIDEN(" ")) ); + sv.remove_suffix(4); + VERIFY( sv == txt ); + + sv = res = std::format(WIDEN("{:=^67}"), si); + VERIFY( sv.starts_with(WIDEN("===")) ); + VERIFY( sv.ends_with(WIDEN("===")) ); + sv.remove_prefix(3); + sv.remove_suffix(3); + VERIFY( sv == txt ); +} + +template<typename _CharT> +void test_local_info() +{ + using String = std::basic_string<_CharT>; + using StringView = std::basic_string_view<_CharT>; + + const sys_info s1 + { + sys_days(2015y/September/11) + 2h, + sys_days(2016y/March/13) + 2h, + -5h, + 0h, + "EET" + }; + const sys_info s2 + { + sys_days(2016y/March/13) + 2h, + sys_days(2015y/September/15) + 2h, + -4h, + 1h, + "EDT" + }; + + const StringView single + = WIDEN("[2015-09-11 02:00:00,2016-03-13 02:00:00,-05:00:00,0min,EET]"); + const StringView both + = WIDEN(" local time between " + "[2015-09-11 02:00:00,2016-03-13 02:00:00,-05:00:00,0min,EET]" + " and " + "[2016-03-13 02:00:00,2015-09-15 02:00:00,-04:00:00,60min,EDT]"); + + const local_info l1{local_info::nonexistent, s1, s2}; + auto exp = WIDEN("[nonexistent") + String(both) + WIDEN("]"); + verify( l1, StringView(exp) ); + + const local_info l2{local_info::ambiguous, s1, s2}; + exp = WIDEN("[ambiguous") + String(both) + WIDEN("]"); + verify( l2, StringView(exp) ); + + const local_info l3{local_info::unique, s1, s1}; + exp = WIDEN("[") + String(single) + WIDEN("]"); + verify( l3, StringView(exp) ); + + String res; + StringView sv; + + sv = res = std::format(WIDEN("{:65}"), l3); + VERIFY( sv.ends_with(WIDEN(" ")) ); + sv.remove_suffix(3); + VERIFY( sv == exp ); + + sv = res = std::format(WIDEN("{:=^67}"), l3); + VERIFY( sv.starts_with(WIDEN("==")) ); + VERIFY( sv.ends_with(WIDEN("===")) ); + sv.remove_prefix(2); + sv.remove_suffix(3); + VERIFY( sv == exp ); +} + +template<typename CharT> +void +test_infos() +{ + test_sys_info<CharT>(); + test_local_info<CharT>(); +} +#endif + template<typename CharT> void test_all() { test_padding<CharT>(); + test_durations<CharT>(); test_calendar<CharT>(); + test_time_points<CharT>(); +#if _GLIBCXX_USE_CXX11_ABI || !_GLIBCXX_USE_DUAL_ABI + test_infos<CharT>(); +#endif } int main() diff --git a/libstdc++-v3/testsuite/std/time/format/pr120481.cc b/libstdc++-v3/testsuite/std/time/format/pr120481.cc new file mode 100644 index 0000000..5878c5b --- /dev/null +++ b/libstdc++-v3/testsuite/std/time/format/pr120481.cc @@ -0,0 +1,324 @@ +// { dg-do run { target c++23 } } +// { dg-options "-fexec-charset=UTF-8" } +// { dg-timeout-factor 2 } + +#include <algorithm> +#include <chrono> +#include <testsuite_hooks.h> + +#define WIDEN_(C, S) ::std::__format::_Widen<C>(S, L##S) +#define WIDEN(S) WIDEN_(_CharT, S) + +using namespace std::chrono; + +template<typename _CharT> +void +test_year() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%Y}"), year(0)); + VERIFY( res == WIDEN("0000") ); + res = std::format(WIDEN("{:%C}"), year(0)); + VERIFY( res == WIDEN("00") ); + res = std::format(WIDEN("{:%y}"), year(0)); + VERIFY( res == WIDEN("00") ); + + res = std::format(WIDEN("{:%Y}"), year(5)); + VERIFY( res == WIDEN("0005") ); + res = std::format(WIDEN("{:%C}"), year(5)); + VERIFY( res == WIDEN("00") ); + res = std::format(WIDEN("{:%y}"), year(5)); + VERIFY( res == WIDEN("05") ); + res = std::format(WIDEN("{:%Y}"), year(-5)); + VERIFY( res == WIDEN("-0005") ); + res = std::format(WIDEN("{:%C}"), year(-5)); + VERIFY( res == WIDEN("-01") ); + res = std::format(WIDEN("{:%y}"), year(-5)); + VERIFY( res == WIDEN("05") ); + + res = std::format(WIDEN("{:%Y}"), year(213)); + VERIFY( res == WIDEN("0213") ); + res = std::format(WIDEN("{:%C}"), year(213)); + VERIFY( res == WIDEN("02") ); + res = std::format(WIDEN("{:%y}"), year(213)); + VERIFY( res == WIDEN("13") ); + res = std::format(WIDEN("{:%Y}"), year(-213)); + VERIFY( res == WIDEN("-0213") ); + res = std::format(WIDEN("{:%C}"), year(-213)); + VERIFY( res == WIDEN("-03") ); + res = std::format(WIDEN("{:%y}"), year(-213)); + VERIFY( res == WIDEN("13") ); + + res = std::format(WIDEN("{:%Y}"), year(7100)); + VERIFY( res == WIDEN("7100") ); + res = std::format(WIDEN("{:%C}"), year(7100)); + VERIFY( res == WIDEN("71") ); + res = std::format(WIDEN("{:%y}"), year(7100)); + VERIFY( res == WIDEN("00") ); + res = std::format(WIDEN("{:%Y}"), year(-7100)); + VERIFY( res == WIDEN("-7100") ); + res = std::format(WIDEN("{:%C}"), year(-7100)); + VERIFY( res == WIDEN("-71") ); + res = std::format(WIDEN("{:%y}"), year(-7100)); + VERIFY( res == WIDEN("00") ); + + res = std::format(WIDEN("{:%Y}"), year(12101)); + VERIFY( res == WIDEN("12101") ); + res = std::format(WIDEN("{:%C}"), year(12101)); + VERIFY( res == WIDEN("121") ); + res = std::format(WIDEN("{:%y}"), year(12101)); + VERIFY( res == WIDEN("01") ); + res = std::format(WIDEN("{:%Y}"), year(-12101)); + VERIFY( res == WIDEN("-12101") ); + res = std::format(WIDEN("{:%C}"), year(-12101)); + VERIFY( res == WIDEN("-122") ); + res = std::format(WIDEN("{:%y}"), year(-12101)); + VERIFY( res == WIDEN("01") ); +} + +template<typename _CharT> +void +test_month() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%m}"), month(5)); + VERIFY( res == WIDEN("05") ); + res = std::format(WIDEN("{:%m}"), month(50)); + VERIFY( res == WIDEN("50") ); + res = std::format(WIDEN("{:%m}"), month(127)); + VERIFY( res == WIDEN("127") ); + res = std::format(WIDEN("{:%m}"), month(254)); + VERIFY( res == WIDEN("254") ); +} + +template<typename _CharT> +void +test_day() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%d}"), day(3)); + VERIFY( res == WIDEN("03") ); + res = std::format(WIDEN("{:%d}"), day(22)); + VERIFY( res == WIDEN("22") ); + res = std::format(WIDEN("{:%d}"), day(100)); + VERIFY( res == WIDEN("100") ); + res = std::format(WIDEN("{:%d}"), day(207)); + VERIFY( res == WIDEN("207") ); + + res = std::format(WIDEN("{:%e}"), day(5)); + VERIFY( res == WIDEN(" 5") ); + res = std::format(WIDEN("{:%e}"), day(99)); + VERIFY( res == WIDEN("99") ); + res = std::format(WIDEN("{:%e}"), day(183)); + VERIFY( res == WIDEN("183") ); + res = std::format(WIDEN("{:%e}"), day(214)); + VERIFY( res == WIDEN("214") ); +} + +template<typename _CharT> +void +test_date() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%F}"), year(-22)/month(10)/day(20)); + VERIFY( res == WIDEN("-0022-10-20") ); + res = std::format(WIDEN("{:%D}"), year(-22)/month(10)/day(20)); + VERIFY( res == WIDEN("10/20/22") ); + + res = std::format(WIDEN("{:%F}"), year(-2020)/month(123)/day(44)); + VERIFY( res == WIDEN("-2020-123-44") ); + res = std::format(WIDEN("{:%D}"), year(-2020)/month(123)/day(44)); + VERIFY( res == WIDEN("123/44/20") ); + + res = std::format(WIDEN("{:%F}"), year(-23404)/month(99)/day(223)); + VERIFY( res == WIDEN("-23404-99-223") ); + res = std::format(WIDEN("{:%D}"), year(-23404)/month(99)/day(223)); + VERIFY( res == WIDEN("99/223/04") ); + + res = std::format(WIDEN("{:%F}"), year(10000)/month(220)/day(100)); + VERIFY( res == WIDEN("10000-220-100") ); + res = std::format(WIDEN("{:%D}"), year(10000)/month(220)/day(100)); + VERIFY( res == WIDEN("220/100/00") ); +} + +template<typename _CharT> +void +test_weekday() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%w}"), weekday(0)); + VERIFY( res == WIDEN("0") ); + res = std::format(WIDEN("{:%u}"), weekday(0)); + VERIFY( res == WIDEN("7") ); + + res = std::format(WIDEN("{:%w}"), weekday(7)); + VERIFY( res == WIDEN("0") ); + res = std::format(WIDEN("{:%u}"), weekday(7)); + VERIFY( res == WIDEN("7") ); + + res = std::format(WIDEN("{:%w}"), weekday(8)); + VERIFY( res == WIDEN("8") ); + res = std::format(WIDEN("{:%u}"), weekday(8)); + VERIFY( res == WIDEN("8") ); + + res = std::format(WIDEN("{:%w}"), weekday(10)); + VERIFY( res == WIDEN("10") ); + res = std::format(WIDEN("{:%u}"), weekday(10)); + VERIFY( res == WIDEN("10") ); + + res = std::format(WIDEN("{:%w}"), weekday(76)); + VERIFY( res == WIDEN("76") ); + res = std::format(WIDEN("{:%u}"), weekday(76)); + VERIFY( res == WIDEN("76") ); + + res = std::format(WIDEN("{:%w}"), weekday(100)); + VERIFY( res == WIDEN("100") ); + res = std::format(WIDEN("{:%u}"), weekday(100)); + VERIFY( res == WIDEN("100") ); + + res = std::format(WIDEN("{:%w}"), weekday(202)); + VERIFY( res == WIDEN("202") ); + res = std::format(WIDEN("{:%u}"), weekday(202)); + VERIFY( res == WIDEN("202") ); +} + +template<typename _CharT> +void +test_hour() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%H}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("00") ); + res = std::format(WIDEN("{:%R}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("00:05") ); + res = std::format(WIDEN("{:%T}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("00:05:06") ); + res = std::format(WIDEN("{:%I}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("12") ); + res = std::format(WIDEN("{:%p}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("07") ); + res = std::format(WIDEN("{:%R}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("07:15") ); + res = std::format(WIDEN("{:%T}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("07:15:06") ); + res = std::format(WIDEN("{:%I}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("07") ); + res = std::format(WIDEN("{:%p}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("15") ); + res = std::format(WIDEN("{:%R}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("15:55") ); + res = std::format(WIDEN("{:%T}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("15:55:26") ); + res = std::format(WIDEN("{:%I}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("03") ); + res = std::format(WIDEN("{:%p}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("PM") ); + + res = std::format(WIDEN("{:%H}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("50") ); + res = std::format(WIDEN("{:%R}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("50:33") ); + res = std::format(WIDEN("{:%T}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("50:33:37") ); + res = std::format(WIDEN("{:%I}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("02") ); + res = std::format(WIDEN("{:%p}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("100") ); + res = std::format(WIDEN("{:%R}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("100:21") ); + res = std::format(WIDEN("{:%T}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("100:21:48") ); + res = std::format(WIDEN("{:%I}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("04") ); + res = std::format(WIDEN("{:%p}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), 228h + 45min + 33s); + VERIFY( res == WIDEN("228") ); + res = std::format(WIDEN("{:%R}"), 228h + 45min + 33s); + VERIFY( res == WIDEN("228:45") ); + res = std::format(WIDEN("{:%T}"), 228h + 45min + 33s); + VERIFY( res == WIDEN("228:45:33") ); + res = std::format(WIDEN("{:%I}"), 228h + 4min + 33s); + VERIFY( res == WIDEN("12") ); + res = std::format(WIDEN("{:%p}"), 228h + 4min + 33s); + VERIFY( res == WIDEN("PM") ); + + res = std::format(WIDEN("{:%H}"), 1024h + 3min); + VERIFY( res == WIDEN("1024") ); + res = std::format(WIDEN("{:%R}"), 1024h + 3min); + VERIFY( res == WIDEN("1024:03") ); + res = std::format(WIDEN("{:%T}"), 1024h + 3min); + VERIFY( res == WIDEN("1024:03:00") ); + res = std::format(WIDEN("{:%I}"), 1024h + 3min); + VERIFY( res == WIDEN("04") ); + res = std::format(WIDEN("{:%p}"), 1024h + 3min); + VERIFY( res == WIDEN("PM") ); + + res = std::format(WIDEN("{:%H}"), 2039h); + VERIFY( res == WIDEN("2039") ); + res = std::format(WIDEN("{:%R}"), 2039h); + VERIFY( res == WIDEN("2039:00") ); + res = std::format(WIDEN("{:%T}"), 2039h); + VERIFY( res == WIDEN("2039:00:00") ); + res = std::format(WIDEN("{:%I}"), 2039h); + VERIFY( res == WIDEN("11") ); + res = std::format(WIDEN("{:%p}"), 2039h); + VERIFY( res == WIDEN("PM") ); + + res = std::format(WIDEN("{:%H}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("22111") ); + res = std::format(WIDEN("{:%R}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("22111:59") ); + res = std::format(WIDEN("{:%T}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("22111:59:59") ); + res = std::format(WIDEN("{:%I}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("07") ); + res = std::format(WIDEN("{:%p}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("-22111") ); + res = std::format(WIDEN("{:%R}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("-22111:59") ); + res = std::format(WIDEN("{:%T}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("-22111:59:59") ); + res = std::format(WIDEN("{:%I}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("-07") ); + res = std::format(WIDEN("{:%p}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("AM") ); +} + +int main() +{ + test_year<char>(); + test_month<char>(); + test_day<char>(); + test_date<char>(); + test_weekday<char>(); + test_hour<char>(); + +#ifdef _GLIBCXX_USE_WCHAR_T + test_year<wchar_t>(); + test_month<wchar_t>(); + test_day<wchar_t>(); + test_date<wchar_t>(); + test_weekday<wchar_t>(); + test_hour<wchar_t>(); +#endif // _GLIBCXX_USE_WCHAR_T +} |